Hi
I have recently tried to combine 2 different workbooks that I have to make my workflow more efficient. Both workbooks are very similar although one workbook copies and pastes to a worksheet 1 row at a time whilst the other workbook copies a heap of data 275 rows at a time. I can get it to work but the worksheets I want to have spaced at 1 row at a time now are spaced at 275 rows at a time and if I try to make it 1 row at a time I delete out all of the data on the other worksheet that is supposed to be spaced at 275 rows at a time. Please help - I know it will be a simple solution I just can't seem to figure it out. The code is below - I want all of the WS1 & WS2 items spaced 1 row at a time and I want ws3 spaced at 275 rows at time - if that makes sense
Any help will be greatly appreciated
I have recently tried to combine 2 different workbooks that I have to make my workflow more efficient. Both workbooks are very similar although one workbook copies and pastes to a worksheet 1 row at a time whilst the other workbook copies a heap of data 275 rows at a time. I can get it to work but the worksheets I want to have spaced at 1 row at a time now are spaced at 275 rows at a time and if I try to make it 1 row at a time I delete out all of the data on the other worksheet that is supposed to be spaced at 275 rows at a time. Please help - I know it will be a simple solution I just can't seem to figure it out. The code is below - I want all of the WS1 & WS2 items spaced 1 row at a time and I want ws3 spaced at 275 rows at time - if that makes sense
Any help will be greatly appreciated
VBA Code:
Option Explicit
Sub RunAllMacros()
CommandButton1_Click
test
sortMyData
delrowsifzero
consolidatedata
End Sub
Sub CommandButton1_Click()
Dim x, fldr As FileDialog, SelFold As String, i As Long
Dim ws As Worksheet, ws1, ws2, ws3 As Worksheet
Dim Wb As Workbook, Filename As String
Dim screenUpdateState As String
Dim statusBarState As String
Dim eventsState As String
Dim lngrow As Integer
screenUpdateState = Application.ScreenUpdating
statusBarState = Application.DisplayStatusBar
eventsState = Application.EnableEvents
'turn off some Excel functionality for faster performance
Application.ScreenUpdating = False
Application.DisplayStatusBar = False
Application.EnableEvents = False
'User Selects desired Folder
Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
With fldr
.Title = "Select a Folder"
If .Show <> -1 Then GoTo Cleanup
SelFold = .SelectedItems(1)
End With
'All .xls* files in Selected FolderPath including Sub folders are put into an array
x = Split(CreateObject("wscript.shell").exec("cmd /c Dir """ & SelFold & "\*.xls"" /s/b").stdout.readall, vbCrLf)
Set ws1 = ThisWorkbook.Sheets("Labour & Material")
Set ws2 = ThisWorkbook.Sheets("Total Hours For All Units")
Set ws3 = ThisWorkbook.Sheets("sheet9")
'Loop through that array
For i = LBound(x) To UBound(x) - 1
'Open (in background) the Workbook
With GetObject(x(i))
ThisWorkbook.Sheets(1).UsedRange
Filename = Split(x(i), "\")(UBound(Split(x(i), "\")))
Set Wb = Workbooks(Filename)
Set ws = Nothing
'On Error Resume Next
'change sheet name here
Set ws = Wb.Sheets("Total Quantities")
On Error GoTo 0
If Not ws Is Nothing Then
If lngrow = 0 Then
lngrow = 5
Else
lngrow = lngrow + 1
lngrow = lngrow + 275
End If
ws1.Cells(lngrow, "A").Value = ws.Range("A1").Value
ws1.Cells(lngrow, "B").Value = ws.Range("I2").Value
ws1.Cells(lngrow, "C").Value = ws.Range("C2").Value
ws1.Cells(lngrow, "E").Value = ws.Range("C3").Value
ws1.Cells(lngrow, "G").Value = ws.Range("C4").Value
ws2.Cells(lngrow, "B").Value = ws.Range("B8").Value
ws2.Cells(lngrow, "C").Value = ws.Range("B9").Value
ws2.Cells(lngrow, "D").Value = ws.Range("B10").Value
ws2.Cells(lngrow, "E").Value = ws.Range("B11").Value
ws2.Cells(lngrow, "F").Value = ws.Range("B12").Value
ws2.Cells(lngrow, "G").Value = ws.Range("B13").Value
ws3.Range("A2:A228").Offset(lngrow, 0).Value = ws.Range("A16:A242").Value
ws3.Range("B2:B228").Offset(lngrow, 0).Value = ws.Range("C16:C242").Value
ws3.Range("E2:E228").Offset(lngrow, 0).Value = ws.Range("H16:H242").Value
ws3.Range("D2:D228").Offset(lngrow, 0).Value = ws.Range("E16:E242").Value
ws3.Range("F2:F228").Offset(lngrow, 0).Value = ws.Range("F16:F242").Value
ws3.Range("A229:A274").Offset(lngrow, 0).Value = ws.Range("I16:I61").Value
ws3.Range("b229:b274").Offset(lngrow, 0).Value = ws.Range("J16:J61").Value
ws3.Range("d229:d274").Offset(lngrow, 0).Value = ws.Range("K16:K61").Value
ws3.Range("e229:e274").Offset(lngrow, 0).Value = ws.Range("l16:l61").Value
End If
.Close
End With
Next i
Cleanup:
Set fldr = Nothing
End Sub
Sub test()
Dim SheetNum As Variant
Dim Sh As Variant
Dim SoRng As Variant
Dim ColNo As Variant
Dim Col As Variant
SheetNum = Array(2, 3, 6, 8)
For Each Sh In Sheets(SheetNum)
Sh.Select
Set SoRng = Sh.Range("A5", Sh.Range("A5").End(xlToRight).Address)
AdvFil SoRng
Next
Sheets(5).Select
Set SoRng = Sheets(5).Range("A5:A5")
AdvFil SoRng
Sheets(4).Select
ColNo = Array("D", "F", "H")
For Each Col In ColNo
Set SoRng = Sheets(4).Range(Col & "5:" & Col & "5")
AdvFil SoRng
Next
End Sub
Sub AdvFil(ByVal x As Range)
Dim LrNum As String
Dim DesRng As Variant
LrNum = Sheets(4).Cells(Rows.Count, "A").End(xlUp).Row
If InStr(1, x.Address, ":") > 0 Then
DesRng = Left(x.Address, Len(x.Address) - 1) & LrNum
Else
DesRng = x.Address & ":" & Left(x.Address, Len(x.Address) - 1) & LrNum
End If
x.AutoFill Destination:=Range(DesRng)
End Sub
Sub sortMyData()
Dim LastRow As Long
Dim myRng As Range
With ActiveWorkbook.Worksheets("Sheet9")
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
Set myRng = .Range("a1:f" & LastRow)
myRng.Sort Key1:=.Columns(1), Order1:=xlAscending, _
Header:=xlYes, OrderCustom:=1, MatchCase:=False, _
Orientation:=xlTopToBottom
End With
End Sub
Sub delrowsifzero()
Application.ScreenUpdating = False
Dim LastRow As Long
Worksheets("sheet9").Activate
On Error Resume Next
LastRow = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
Dim x As Long
ActiveWorkbook.Worksheets("Sheet9").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Sheet9").Sort.SortFields.Add Key:=Range("A2:f" & LastRow) _
, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("Sheet9").Sort
.SetRange Range("A:f" & LastRow)
.Header = xlGuess
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
For x = LastRow To 2 Step -1
If Cells(x, 2) = "" Or Cells(x, 2) = 0 Then
Rows(x).EntireRow.Delete
End If
Next x
Application.ScreenUpdating = True
End Sub
Sub consolidatedata()
Worksheets("Sheet9").Range("h2").Consolidate _
Sources:=Array("Sheet9!data"), _
Function:=xlSum, LeftColumn:=True
End Sub
