Fixing Up Copying & Pasting Issue for 2 different sheets in the same workbook


New Member
Mar 22, 2014
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()
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("").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))
            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
        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
        End With
    Next i

    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)
    Set SoRng = Sh.Range("A5", Sh.Range("A5").End(xlToRight).Address)
    AdvFil SoRng

Set SoRng = Sheets(5).Range("A5:A5")
AdvFil SoRng

ColNo = Array("D", "F", "H")
    For Each Col In ColNo
    Set SoRng = Sheets(4).Range(Col & "5:" & Col & "5")
    AdvFil SoRng

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
    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, _

End With

End Sub
Sub delrowsifzero()
    Application.ScreenUpdating = False
    Dim LastRow As Long
     On Error Resume Next
       LastRow = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    Dim x As Long
    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
    End With
    For x = LastRow To 2 Step -1
        If Cells(x, 2) = "" Or Cells(x, 2) = 0 Then
        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

Excel Facts

Enter current date or time
Ctrl+: enters current time. Ctrl+; enters current date. Use Ctrl+: Ctrl+; Enter for current date & time.


Well-known Member
Mar 22, 2015
Office Version
  1. 2013
  1. Windows
VBA Code:
 lngrow1 = lngrow1 + 1
        lngrow = lngrow + 275
Then ...


Well-known Member
Mar 22, 2015
Office Version
  1. 2013
  1. Windows
You are welcome
And Thank you for the feedback
Be happy & safe

Watch MrExcel Video

Forum statistics

Latest member

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back