Copy paste the value between two worksheets in different workbook only if they have same sheet name

[2020Rivalry]

Scenario: There have two excel files, one for 2pm and one for 3pm meeting. The files are not exact same, but currently we need to copy some of the data from 2pm file to 3pm one everyday.

Requirements: Only copy the value between two worksheet on two different workbook (2pm and 3pm) if they have the same sheet name. For example, copy paste value from sheet “WK1” workbook “2pm” to sheet “WK1” workbook “3pm”.

3pmTrial.xlsx
	A	B	C	D	E	F	G	H	I	J
1
2	Wk	3			WK3
3
4	KPIs		Target	Accomplished
5				Mon	Tue	Wed	Thu	Fri	Sat	Sun
6	KPI1		0
7	KPI2		L
8	KPI3		2 per Day
9			0
10	KPI4		L
WK3

Cell Formulas
Range	Formula
E2	E2	=CONCAT("WK",B2)

I'm trying with code below but getting this error (Compile error: Invalid or unqualified reference)

Public Sub insert_Data()

Application.ScreenUpdating = False

Dim wb1, wb2 As Workbook
Set wb1 = Workbooks.Open("G:\DDS\TrialData\2pmTrial.xlsx")
Set wb2 = Workbooks.Open("G:\DDS\TrialData\3pmTrial.xlsx")

Dim sh1 As Worksheets
Set sh1 = Workbooks("3pmTrial.xlsx").Worksheets("WK*")

For Each sh1 In Worksheets
    With Workbooks("3pmTrial.xlsx")
        Workbooks("2pmTrial.xlsx").Worksheets(.Range("E2").Value).Range("D6:J10").Value = .Worksheets(.Range("E2").Value).Range("D6:J10").Value
    End With
Next

Application.ScreenUpdating = True
 
End Sub

Thank you!

 

[2020Rivalry]

Currently I have only two sheets: WK14 and WK01

The name return for ?sh1.name is WK01

 

[Alex Blakenburg]

Try the find entire content "Daily Action Plan" on that sheet

 

[2020Rivalry]

ya, try and no issue

 

[Alex Blakenburg]

Are you able to share both your test workbooks with your current code included via a share platform (dropbox, google drive, onedrive etc) ?
Also reconfirm which line you are getting the error on and that it is still error 91.

 

[2020Rivalry]

Hi Alex,

ya sure, which one you prefer (google drive and onedrive)
this line still getting error: Set rngsh1 = findRng(sh1:=sh1, strFind:="Daily Action Plan").Resize(, 18)

 

[Alex Blakenburg]

Either is fine. Make it google drive. You will need to set it to share with everyone with the link and post the link here.

Since it made a past "Main Losses", I would have thought it was something specific with the text "Daily Action Plan" but if you give me access to the files I can have a look.

 

[2020Rivalry]

DDS - Google Drive

drive.google.com

 

[2020Rivalry]

VBA Code:

Option Explicit

Public Sub insert_Data()

Application.ScreenUpdating = False

Dim wb1 As Workbook, wb2 As Workbook                    ' Need to edit every year (the new files location)
Set wb1 = Workbooks.Open("G:\DDS\Daily DDS (8.45am) Yr2022 v2 ExampleFile.xlsx")
Set wb2 = Workbooks.Open("G:\DDS\Daily DDS (9.45am) Y2022 ExampleFile.xlsm")

Dim sh1 As Variant
Dim sh2 As Worksheet

Dim rngsh1 As Range
Dim rngsh2 As Range

Dim foundRow As Long, startRow As Long, endRow As Long

For Each sh1 In wb1.Worksheets

    If UCase(sh1.Name) Like "WK*" Then
        On Error Resume Next
            Set sh2 = wb2.Worksheets(sh1.Name)
        On Error GoTo 0
        
        If Not sh2 Is Nothing Then
            sh2.Range("B17:D21").Value = sh1.Range("B4:D8").Value
            sh2.Range("F17:L21").Value = sh1.Range("E4:K8").Value ' safety incident, safety trigger, pulsar, quality trigger
                      
            sh2.Range("B22:D41").Value = sh1.Range("B11:D30").Value
            sh2.Range("F22:L41").Value = sh1.Range("E11:K30").Value ' quality performance

'            sh2.Range("B62:S72").Value = sh1.Range("B73:S85").Value ' main losses, need to adjust the row height manually
            Set rngsh1 = findRng(sh1:=sh1, strFind:="Main Losses").Resize(, 18)
            Set rngsh2 = findRng1(sh2:=sh2, strFind:="Main Losses").Resize(, 18)
            rngsh1.Copy
            rngsh2.Insert Shift:=xlShiftDown
            
'            sh2.Range("B76:S78").Value = sh1.Range("B89:S91").Value ' daily action plan
            Set rngsh1 = findRng(sh1:=sh1, strFind:="Daily Action Plan").Resize(, 18)
            Set rngsh2 = findRng1(sh2:=sh2, strFind:="Daily Action Plan").Resize(, 18)
            rngsh1.Copy
            rngsh2.Insert Shift:=xlShiftDown
            
'            sh2.Range("B82:S89").Value = sh1.Range("B95:S102").Value ' follow up
            Set rngsh1 = findRng(sh1:=sh1, strFind:="Follow up").Resize(, 18)
            Set rngsh2 = findRng1(sh2:=sh2, strFind:="Follow up").Resize(, 18)
            rngsh1.Copy
            rngsh2.Insert Shift:=xlShiftDown
            
        End If
    End If
Next

Application.ScreenUpdating = True
 
End Sub

Function findRng(sh1 As Variant, ByVal strFind As String) As Range

    ' Find start and end of the 3 sections
    Dim foundRow As Long, startRow As Long, endRow As Long
    
    Select Case strFind
    
        Case "Main Losses"
            ' find start of section
            strFind = "Main Losses"
            With Application
                foundRow = .IfError(.Match(strFind, sh1.Range("B:B"), 0), 0)
            End With
            If foundRow = 0 Then
                Set findRng = Nothing
                Exit Function
            End If
            startRow = foundRow + 2
            
            ' find next section
            strFind = "Daily Action Plan"
            With Application
                foundRow = .IfError(.Match(strFind, sh1.Range("B:B"), 0), 0)
            End With
            If foundRow = 0 Then
                Set findRng = Nothing
                Exit Function
            End If
            
            endRow = sh1.Range("B" & foundRow).End(xlUp).Row
            If endRow < startRow Then
                Set findRng = Nothing
                Exit Function
            End If
            
        Case "Daily Action Plan"
            ' find start of section
            strFind = "Daily Action Plan"
            With Application
                foundRow = .IfError(.Match(strFind, sh1.Range("B:B"), 0), 0)
            End With
            If foundRow = 0 Then
                Set findRng = Nothing
                Exit Function
            End If
            startRow = foundRow + 2
            
            ' find next section
            strFind = "Follow up"
            With Application
                foundRow = .IfError(.Match(strFind, sh1.Range("B:b"), 0), 0)
            End With
            If foundRow = 0 Then
                Set findRng = Nothing
                Exit Function
            End If
            
            endRow = sh1.Range("B" & foundRow).End(xlUp).Row
            If endRow < startRow Then
                Set findRng = Nothing
                Exit Function
            End If
               
        Case "Follow up"
            ' find start of section
            strFind = "Follow up"
            With Application
                foundRow = .IfError(.Match(strFind, sh1.Range("B:b"), 0), 0)
            End With
            If foundRow = 0 Then
                Set findRng = Nothing
                Exit Function
            End If
            startRow = foundRow + 2
            
            ' Last section on sheet - so get last data row
            endRow = sh1.Range("B" & Rows.Count).End(xlUp).Row
            If endRow < startRow Then
                Set findRng = Nothing
                Exit Function
            End If
        
    End Select
    
    Set findRng = sh1.Range(sh1.Cells(startRow, "B"), sh1.Cells(endRow, "B"))
            
End Function

Function findRng1(sh2 As Worksheet, ByVal strFind As String) As Range

    ' Find start and end of the 3 sections
    Dim foundRow As Long, startRow As Long
    
    Select Case strFind
    
        Case "Main Losses"
            ' find start of section
            strFind = "Main Losses"
            With Application
                foundRow = .IfError(.Match(strFind, sh2.Range("B:B"), 0), 0)
            End With
            If foundRow = 0 Then
                Set findRng1 = Nothing
                Exit Function
            End If
            startRow = foundRow + 2
            
        Case "Daily Action Plan"
            ' find start of section
            strFind = "Daily Action Plan"
            With Application
                foundRow = .IfError(.Match(strFind, sh2.Range("B:B"), 0), 0)
            End With
            If foundRow = 0 Then
                Set findRng1 = Nothing
                Exit Function
            End If
            startRow = foundRow + 2
               
        Case "Follow up"
            ' find start of section
            strFind = "Follow up"
            With Application
                foundRow = .IfError(.Match(strFind, sh2.Range("B:B"), 0), 0)
            End With
            If foundRow = 0 Then
                Set findRng1 = Nothing
                Exit Function
            End If
            startRow = foundRow + 2
        
    End Select
    
    Set findRng1 = sh2.Range(sh2.Cells(startRow, "B"), sh2.Cells(startRow, "S"))
            
End Function

One more issue is the rows will keep stacking. Is there a way to reset it?

 

[Alex Blakenburg]

One more issue is the rows will keep stacking. Is there a way to reset it?

The easiest way would be to have another sub that deletes from Main down in the WK* sheets and copies from Main down from the New Template sheet.

this line still getting error: Set rngsh1 = findRng(sh1:=sh1, strFind:="Daily Action Plan").Resize(, 18)

Replace all your code (the main sub AND the 2 functions) with this.
The main change to the 2 Functions using the naming of 1 & 2 as the rest of the code but it meant a few changes.

Public Sub insert_Data()
Application.ScreenUpdating = False

Dim wb1 As Workbook, wb2 As Workbook                    ' Need to edit every year (the new files location)
Set wb1 = Workbooks.Open("G:\DDS\Daily DDS (8.45am) Yr2022 v2 ExampleFile.xlsx")
Set wb2 = Workbooks.Open("G:\DDS\Daily DDS (9.45am) Y2022 ExampleFile.xlsm")

Dim sh1 As Variant
Dim sh2 As Worksheet

Dim rngsh1 As Range
Dim rngsh2 As Range

Dim foundRow As Long, startRow As Long, endRow As Long
Dim sectionHdg As String

For Each sh1 In wb1.Worksheets

    If UCase(sh1.Name) Like "WK*" Then
        On Error Resume Next
            Set sh2 = wb2.Worksheets(sh1.Name)
        On Error GoTo 0
       
        If Not sh2 Is Nothing Then
            sh2.Range("B17:D21").Value = sh1.Range("B4:D8").Value
            sh2.Range("F17:L21").Value = sh1.Range("E4:K8").Value ' safety incident, safety trigger, pulsar, quality trigger
                     
            sh2.Range("B22:D41").Value = sh1.Range("B11:D30").Value
            sh2.Range("F22:L41").Value = sh1.Range("E11:K30").Value ' quality performance

            ' main losses
            sectionHdg = "Main Losses"
            Set rngsh1 = findRng1(sh1:=sh1, strFind:=sectionHdg)
            Set rngsh2 = findRng2(sh2:=sh2, strFind:=sectionHdg)
            If Not rngsh1 Is Nothing And Not rngsh2 Is Nothing Then
                Set rngsh1 = rngsh1.Resize(, 18)
                Set rngsh2 = rngsh2.Resize(, 18)
                rngsh1.Copy
                rngsh2.Insert Shift:=xlShiftDown
            End If
           
            ' daily action plan
            sectionHdg = "Daily Action Plan"
            Set rngsh1 = findRng1(sh1:=sh1, strFind:=sectionHdg)
            Set rngsh2 = findRng2(sh2:=sh2, strFind:=sectionHdg)
            If Not rngsh1 Is Nothing And Not rngsh2 Is Nothing Then
                Set rngsh1 = rngsh1.Resize(, 18)
                Set rngsh2 = rngsh2.Resize(, 18)
                rngsh1.Copy
                rngsh2.Insert Shift:=xlShiftDown
            End If
           
            ' follow up
            sectionHdg = "Follow up"
            Set rngsh1 = findRng1(sh1:=sh1, strFind:=sectionHdg)
            Set rngsh2 = findRng2(sh2:=sh2, strFind:=sectionHdg)
            If Not rngsh1 Is Nothing And Not rngsh2 Is Nothing Then
                Set rngsh1 = rngsh1.Resize(, 18)
                Set rngsh2 = rngsh2.Resize(, 18)
                rngsh1.Copy
                rngsh2.Insert Shift:=xlShiftDown
            End If

        End If
    End If
Next

Application.ScreenUpdating = True
 
End Sub

Function findRng1(sh1 As Variant, ByVal strFind As String) As Range

    ' Find start and end of the 3 sections
    Dim foundRow As Long, startRow As Long, endRow As Long
   
    Select Case strFind
   
        Case "Main Losses"
            ' find start of section
            strFind = "Main Losses"
            With Application
                foundRow = .IfError(.Match(strFind, sh1.Range("B:B"), 0), 0)
            End With
            If foundRow = 0 Then
                Set findRng1 = Nothing
                Exit Function
            End If
            startRow = foundRow + 2
           
            ' find next section
            strFind = "Daily Action Plan"
            With Application
                foundRow = .IfError(.Match(strFind, sh1.Range("B:B"), 0), 0)
            End With
            If foundRow = 0 Then
                Set findRng1 = Nothing
                Exit Function
            End If
           
            endRow = sh1.Range("B" & foundRow).End(xlUp).Row
            If endRow < startRow Then
                Set findRng1 = Nothing
                Exit Function
            End If
           
        Case "Daily Action Plan"
            ' find start of section
            strFind = "Daily Action Plan"
            With Application
                foundRow = .IfError(.Match(strFind, sh1.Range("B:B"), 0), 0)
            End With
            If foundRow = 0 Then
                Set findRng1 = Nothing
                Exit Function
            End If
            startRow = foundRow + 2
           
            ' find next section
            strFind = "Follow up"
            With Application
                foundRow = .IfError(.Match(strFind, sh1.Range("B:B"), 0), 0)
            End With
            If foundRow = 0 Then
                Set findRng1 = Nothing
                Exit Function
            End If
           
            endRow = sh1.Range("B" & foundRow).End(xlUp).Row
            If endRow < startRow Then
                Set findRng1 = Nothing
                Exit Function
            End If
              
        Case "Follow up"
            ' find start of section
            strFind = "Follow up"
            With Application
                foundRow = .IfError(.Match(strFind, sh1.Range("B:b"), 0), 0)
            End With
            If foundRow = 0 Then
                Set findRng1 = Nothing
                Exit Function
            End If
            startRow = foundRow + 2
           
            ' Last section on sheet - so get last data row
            endRow = sh1.Range("B" & Rows.Count).End(xlUp).Row
            If endRow < startRow Then
                Set findRng1 = Nothing
                Exit Function
            End If
       
    End Select
   
    Set findRng1 = sh1.Range(sh1.Cells(startRow, "B"), sh1.Cells(endRow, "B"))
           
End Function

Function findRng2(sh2 As Worksheet, ByVal strFind As String) As Range

    ' Find start and end of the 3 sections
    Dim foundRow As Long, startRow As Long
   
    Select Case strFind
   
        Case "Main Losses"
            ' find start of section
            strFind = "Main Losses"
            With Application
                foundRow = .IfError(.Match(strFind, sh2.Range("B:B"), 0), 0)
            End With
            If foundRow = 0 Then
                Set findRng2 = Nothing
                Exit Function
            End If
            startRow = foundRow + 2
           
        Case "Daily Action Plan"
            ' find start of section
            strFind = "Daily Action Plan"
            With Application
                foundRow = .IfError(.Match(strFind, sh2.Range("B:B"), 0), 0)
            End With
            If foundRow = 0 Then
                Set findRng2 = Nothing
                Exit Function
            End If
            startRow = foundRow + 2
              
        Case "Follow up"
            ' find start of section
            strFind = "Follow up"
            With Application
                foundRow = .IfError(.Match(strFind, sh2.Range("B:B"), 0), 0)
            End With
            If foundRow = 0 Then
                Set findRng2 = Nothing
                Exit Function
            End If
            startRow = foundRow + 2
       
    End Select
   
    Set findRng2 = sh2.Range(sh2.Cells(startRow, "B"), sh2.Cells(startRow, "S"))
           
End Function

 

[2020Rivalry]

The easiest way would be to have another sub that deletes from Main down in the WK* sheets and copies from Main down from the New Template sheet.

but if I do like that, the data input to 9.45 by my colleague will also get deleted. Is there a way to just delete the data from 8.45... Is it possible?