Copy the missing cells from another workbook

[Cortex1000]

Hi

I am working on a couple of macros and I got stuck on one of the tasks. I got everything working so far but there is one thing I cannot figure out how to put in place. The Idea is that I have 2 workbooks Main wb and Second wb. The VBA is helping to copy the data from second wb to main wb.

I looking to copy the data from column E (test5) from second workbook to column E(test5) in the main workbook if this is missing.

Sorry I cannot use XL2BB

Main WB

test1	test2	test3	test4	test5	test6	test7	test8	test9	test10	test11	test12
			info0	R2000R22102312345	info10	info20	info30	info40	info50
			info1	R2000R22102312342	info11	info21	info31	info41	info51
			info2	R2000R22102312350	info12	info22	info32	info42	info52
			info3	R2000R22102312332	info13	info23	info33	info43	info53
			info4	R2000R22102312312	info14	info24	info34	info44	info54
			info5	R2000R22102312324	info15	info25	info35	info45	info55
			info6	R2000R22102312330	info16	info26	info36	info46	info56
				L3000L07112316852

Second WB

test1	test2	test3	test4	test5	test6	test7	test8	test9	test10	test11	test12
			info0	R2000R22102312345	info10	info20	info30	info40	info50
			info1	R2000R22102312342	info11	info21	info31	info41	info51
			info2	R2000R22102312350	info12	info22	info32	info42	info52
			info3	R2000R22102312332	info13	info23	info33	info43	info53
			info4	R2000R22102312312	info14	info24	info34	info44	info54
			info5	R2000R22102312324	info15	info25	info35	info45	info55
			info6	R2000R22102312330	info16	info26	info36	info46	info56
				L3000L07112316852
				L3000L07112316853
				L3000L07112316854
				L3000L07112316855

Option Explicit
Sub TEST()
    Dim objDic As Object
    Dim i As Long, j As Integer, sKey As String
    Dim arrData, rngData As Range
    Dim arrRec, rngRec As Range
    Dim wb2 As Workbook, Sh_Data As Worksheet
    Dim lastRow As Long
    Set objDic = CreateObject("scripting.dictionary")
    ' Open second workbook
    Set Wb2 = Workbooks.Open("C:\Users\" & Environ$("USERNAME") & "\Desktop\" & "Second.xls")
    Set Sh_Data = wb2.Worksheets("data2")
    ' Read data from sheet
    With Sh_Data
        lastRow = .Cells(.Rows.Count, "E").End(xlUp).Row
        Set rngData = .Range("A1", .Cells(lastRow, 12))
    End With
    arrData = rngData.Value
    wb2.Close False
    ' Load Dict with data
    For i = LBound(arrData) + 1 To UBound(arrData)
        objDic(arrData(i, 5)) = i
    Next i  
    Dim Sh_Record As Worksheet, Main_wk As Workbook
    Set Main_wk = ActiveWorkbook
    Set Sh_Record = Main_wk.Sheets("Data1")
    ' Read data from sheet
    With Sh_Record
        lastRow = .Cells(.Rows.Count, "E").End(xlUp).Row
        Set rngRec = .Range("A1", .Cells(lastRow, 12))
    End With
    arrRec = rngRec.Value
    ' Comparing Col E
    For i = LBound(arrRec) + 1 To UBound(arrRec)
        sKey = arrRec(i, 5)
        If objDic.exists(sKey) Then
            ' Populate Col D to J if matching
            For j = 4 To 10
               If Len(arrRec(i, j))=0 Then arrRec(i, j) = arrData(objDic(sKey), j)
            Next
        End If
    Next i
    ' Update main workbook
    rngRec.Value = arrRec
    Set objDic = Nothing
End Sub

The code you see helped me to get all the info from second wb and fill in the gaps into the main wb. But now I am looking to create a separate macro under the same idea but only to fill me column E values if these are missing in main wb.
I hope someone can have a look and get me an idea of how should I put this in place because what I have done so far didn't work.

 

[Max1616]

There might be a more eloquent solution out there, but I think this will accomplish what you're trying to do:

Sub AddMissing()

Dim wb1 As Workbook
Dim wb2 As Workbook

Dim ws1 As Worksheet
Dim ws2 As Worksheet

Dim lrow1 As Long
Dim lrow2 As Long

Dim i As Long
Dim j As Long

Dim ValueChk As Boolean


Set wb1 = Workbooks("Testbook1.xlsx") 'Main workbook
Set wb2 = Workbooks("Testbook2.xlsx") 'Second workbook

Set ws1 = wb1.Sheets("Sheet1") 'Update sheet name if needed
Set ws2 = wb2.Sheets("Sheet1") 'Update sheet name if needed

lrow1 = ws1.Cells(Rows.Count, 5).End(xlUp).Row
lrow2 = ws2.Cells(Rows.Count, 5).End(xlUp).Row


For i = 2 To lrow2
    
    For j = 2 To lrow1
        If ws1.Cells(j, 5) = ws2.Cells(i, 5) Then
            ValueChk = True
            GoTo Nexti
        End If
    Next j
    
Nexti:

    If ValueChk = False Then
        ws1.Cells(lrow1 + 1, 5) = ws2.Cells(i, 5)
        lrow1 = lrow1 + 1
    End If
    ValueChk = False
    
Next i


End Sub

 

[Max1616]

Note, you'll need to update your workbook and sheet names.

This macro should loop through column 5 in the second workbook, and check each record in column 5 in the main workbook to see if the value already exists. If the record does not exist, it adds it to the bottom of the main workbook in column 5.

 

[Cortex1000]

Hello

Thank you Max for your assistance. I have used your example since you put it down here. This is a bit slow for my record as it takes up to 20 seconds sometimes to loop through the record.

Does anyone else have a better, faster solution for records with a lot of data?

Kind Regards

 

[Max1616]

See if this runs any quicker:

Sub AddMissing()

Dim wb1 As Workbook
Dim wb2 As Workbook

Dim ws1 As Worksheet
Dim ws2 As Worksheet

Dim lrow1 As Long
Dim lrow2 As Long

Dim i As Long
Dim j As Long

Set wb1 = Workbooks("Testbook1.xlsx") 'Main workbook
Set wb2 = Workbooks("Testbook2.xlsx") 'Second workbook

Set ws1 = wb1.Sheets("Sheet1") 'Update sheet name if needed
Set ws2 = wb2.Sheets("Sheet1") 'Update sheet name if needed

lrow1 = ws1.Cells(Rows.Count, 5).End(xlUp).Row
lrow2 = ws2.Cells(Rows.Count, 5).End(xlUp).Row


For i = 2 To lrow2
    If Application.CountIfs(ws1.Range("E:E"), ws2.Cells(i, 5)) = 0 Then
        ws2.Cells(i, 5).Copy ws1.Cells(lrow1 + 1, 5)
        lrow1 = lrow1 + 1
    End If
    
Next i


End Sub