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

Tmini

New Member
Joined
Mar 22, 2014
Messages
27
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

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
 

Excel Facts

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

mohadin

Well-known Member
Joined
Mar 22, 2015
Messages
1,091
Office Version
  1. 2013
Platform
  1. Windows
Hi
try
VBA Code:
 lngrow1 = lngrow1 + 1
        lngrow = lngrow + 275
Then ...
 
Solution

mohadin

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

Watch MrExcel Video

Forum statistics

Threads
1,130,337
Messages
5,641,571
Members
417,223
Latest member
jelena_

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 MrExcel.com.
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 "mrexcel.com".
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
Top