Copying a range from multiple sheets and inserting into multiple sheets in another workbook.

[Nurzhan]

Hallo,
I have 2 workbooks. A and B. A = source, B = Target. Each of them has sheets with the same names. The task is to copy a certain range from A and insert it in a cell below the last occupied one. My code is as follows but it fails to work and I couldn't troubleshoot. could you pls help.

Error appears at

lastRow = WBb.Sheets(sh.Name).Cells(Rows.Count, "B").End(xlUp).row+1

. Error = "91", saying object variable or with block variable no set.

Sub FromA2B()    
    Dim WBa As Workbook
    Dim WBb As Workbook
    Dim sh As Worksheet
    Dim lastRow As Range
    
    Set WBa = ThisWorkbook
    Set WBb = Workbooks("SWDP June 2010 - May 2017 (Oil and WI wells).xlsx")
    
    For Each sh In WBa.Worksheets
        sh.Range("B9:Z39").Copy
        lastRow = WBb.Sheets(sh.Name).Cells(Rows.Count, "B").End(xlUp).row+1
        lastRow.Select
        Selection.Insert Shift:=xlDown
        Application.CutCopyMode = False
    Next sh
End Sub

 

[Fluff]

You're better off using a function

    For Each sh In WBa.Worksheets
      lastRow = sh.Cells(Rows.Count, "B").End(xlUp).Row
      sh.Range("K:L,R:S").Delete shift:=xlToLeft
      If ShtExists(sh.Name, WBb) Then
         sh.Range("B9:Z" & lastRow).Copy
         WBb.Sheets(sh.Name).Cells(Rows.Count, "B").End(xlUp).Offset(1).Insert shift:=xlShiftDown
      End If
    Next sh

and

Public Function ShtExists(ShtName As String, Optional Wbk As Workbook) As Boolean
    If Wbk Is Nothing Then Set Wbk = ActiveWorkbook
    On Error Resume Next
    ShtExists = (LCase(Wbk.Sheets(ShtName).Name) = LCase(ShtName))
    [COLOR=#0000ff]On Error GoTo 0[/COLOR]
End Function

If you do use Resume next you should follow it almost immediately with the line in blue which resets the error handler back to the default

 

[Nurzhan]

Thank you so much Fluff!!! What if there are, say, 10 sheets(sheet names: 10, 24, 35, 55, 303, 217, 216, 303, 724, 725) in the WBa. I wanna do same things but first 5 sheets should be copied to WBb and the rest to WBc? I guess we can use arrow but not sure how to do that.

 

[Fluff]

Something like

Dim Ary As Variant
Ary = Array("10", "24", "35", "55", "303", "217", "216", "303", "724", "725")
For i = 0 To UBound(Ary)
   lastRow = Sheets(Ary(i)).Cells(Rows.Count, "B").End(xlUp).Row
   Sheets(Ary(i)).Range("K:L,R:S").Delete shift:=xlToLeft
   If i <= 4 Then
      If ShtExists(Ary(i), WBb) Then
         Sheets(Ary(i)).Range("B9:Z" & lastRow).Copy
         WBb.Sheets(Ary(i)).Cells(Rows.Count, "B").End(xlUp).Offset(1).Insert shift:=xlShiftDown
      End If
   Else
      If ShtExists(Ary(i), WBc) Then
         Sheets(Ary(i)).Range("B9:Z" & lastRow).Copy
         WBc.Sheets(Ary(i)).Cells(Rows.Count, "B").End(xlUp).Offset(1).Insert shift:=xlShiftDown
      End If
   End If
Next i

 

[Nurzhan]

Hi. Something is wrong, it stops at "Ary"

If ShtExists(Ary(i), WBb) Then

and says "ByRef argument type mismatch. Here's my full code:

Sub FromA2B_1()    Dim WBa As Workbook
    Dim WBb As Workbook
    Dim sh As Worksheet
    Dim lastRow As Long
    Dim Ary As Variant
    Dim i As Integer
     
    
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.Calculation = xlCalculationManual
    
        
    Set WBa = ThisWorkbook
    Set WBb = Workbooks("SWDP June 2010 - May 2017 (Oil and WI wells).xlsx")
    Set WBc = Workbooks("SWDP June 2010 - May 2017 (GC wells).xlsx")
    
    Ary = Array("10", "22", "24", "27", "30", "32", "33", "52", "54", "56", "57", "59", "60", "62", "63", _
    "65", "67", "111", "115b", "117", "124", "31", "40", "45", "51", "123", "701", "703", "724", "725", "410")
    
    For i = 0 To UBound(Ary)
    lastRow = Sheets(Ary(i)).Cells(Rows.Count, "B").End(xlUp).Row
    Sheets(Ary(i)).Range("K:L,R:S").Delete shift:=xlToLeft
    
    If i <= 4 Then
      If ShtExists(Ary(i), WBb) Then
         Sheets(Ary(i)).Range("B9:Z" & lastRow).Copy
         WBb.Sheets(Ary(i)).Cells(Rows.Count, "B").End(xlUp).Offset(1).Insert shift:=xlShiftDown
      End If
   Else
      If ShtExists(Ary(i), WBc) Then
         Sheets(Ary(i)).Range("B9:Z" & lastRow).Copy
         WBc.Sheets(Ary(i)).Cells(Rows.Count, "B").End(xlUp).Offset(1).Insert shift:=xlShiftDown
      End If
   End If
Next i
    
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    Application.Calculation = xlCalculationAutomatic
    
End Sub

and

Public Function ShtExists(ShtName As String, Optional Wbk As Workbook) As Boolean    If Wbk Is Nothing Then Set Wbk = ActiveWorkbook
    On Error Resume Next
    ShtExists = (LCase(Wbk.Sheets(ShtName).Name) = LCase(ShtName))
    On Error GoTo 0
End Function

 

[Fluff]

Try

If ShtExists(CStr(Ary(i)), WBb) Then

for both occasions. You'll also need to declare WBc

 

[Nurzhan]

Dear Fluff, pls help me with the following code. It doesn't want to run

Sub GCWellsToSWDP() 'Copies GC wells to SWDP

    Dim WBa As Workbook
    Dim WBb As Workbook
    Dim sh As Worksheet
    Dim lastRow As Long
    Dim Ary As Variant
    Dim i As Integer
        
         
    Set WBa = ThisWorkbook
    Set WBb = Workbooks("SWDP June 2010 - April 2018 (Gas-Condensate wells).xlsx")
    
    Ary = Array("20", "119", "201", "204", "205", "209", "210", "215", "216", "217", "218", "219", "220", "222", "223", _
    "224", "225", "230", "231", "234", "28", "32", "46", "115", "213", "301", "61", "40", "300", "303", "724", "23", "401", "402", "404", "406", "300", "303", "57")
    
    For i = 0 To UBound(Ary)
      lastRow = Sheets(Ary(i)).Cells(Rows.Count, "B").End(xlUp).Row
      Sheets(Ary(i)).Range("K:L,R:S").Delete Shift:=xlToLeft 'deletes not-needed columns
      Sheets(Ary(i)).Columns("F:F").Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove 
      Sheets(Ary(i)).Range("B9:AD" & lastRow).Copy 
      
      WBb.Sheets(Ary(i)).Cells(Rows.Count, "B").End(xlUp).Offset(1).Insert Shift:=xlShiftDown 
      WBb.Sheets(Ary(i)).Cells(Rows.Count, "F").End(xlUp).Row.Resize(lastRow).Value = "=IF(RC[4]=0;" - ";RC[-1]*RC[20]/1000)"  'It stops running here'
      WBb.Sheets(Ary(i)).Cells(Rows.Count, "AD").End(xlUp).Row.Resize(-50).Value = "=RC[-14]/1000"
      WBb.Sheets(Ary(i)).Cells(Rows.Count, "I").End(xlUp).Row.Resize(, 3).Value = "=SUM(R9C:R[-1]C)"
      WBb.Sheets(Ary(i)).Union(Range("M" & lastRow + 1), Range("N" & lastRow + 1), Range("P" & lastRow + 1)).Value = "=SUM(R9C:R[-1]C)"
      WBb.Sheets(Ary(i)).Union(Range("O" & lastRow + 1), Range("Q" & lastRow + 1)).Value = "=RC[-1]/RC[-6]"
  
    Next i

 

[Fluff]

In what way doesn't it run?

 

[Nurzhan]

Error "13" Type Mismatch at

WBb.Sheets(Ary(i)).Cells(Rows.Count, "F").End(xlUp).Row.Resize(lastRow).Value = "=IF(RC[4]=0;" - ";RC[-1]*RC[20]/1000)"

Basically what I wanted to do are:
Columns "F" and "AD" to autofill with formulas from upper cells
LastRows of columns M, N, and P to be updated with SUM formula
LastRows of columns O, and Q to be updated with Division formula

 

[Fluff]

Try

WBb.Sheets(ary(i)).Cells(Rows.Count, "F").End(xlUp).Resize(LastRow).Formula = "=IF(RC[4]=0,"" - "",RC[-1]*RC[20]/1000)"

 

[Nurzhan]

No success. Same error.