Compare two Arrays and insert missing column Headers

[Denin Srmic]

I am new to Forum and new to VBA but have been following posts here and learning VBA along.
I have gone through this Forum and searched on the web in order to find the way how to compare Arrays and insert missing columns. I have adapted some of the codes generated here by VBA masters but cannot get it to work for the task I have in front of me which is adding missing columns.
I have two Column Header ranges one (Workbook "New") which consist of 216 columns and one of (Workbook "Old") 152. Both ranges, stored in two workbooks. Both have same Column Headers names (i.e, "ID number", "first name", "Surname", "Date of Birth", "Email", "GP Phone Number" etc), but Workbook "Old" has missing columns which I would like to check against Workbook "New" and populate missing Columns from Workbook "New" to Workbook "Old". Workbook Old should at the end have same column Headers as Workbook New, consisting of 216 columns.
After running my code, it adds unfortunately more columns than it should, it appears it adds duplicate columns. Could you please help here out. I would also like to reorder columns in Workbook Old based on patters from Column Header in Workbook New. Any improvements on my code or critics are very welcome. Many thanks.

I hop this make sense.

Public Sub InsertMissingCol()
'with this code we aim to check column headers in Old Workbook and add missing one from New. _
After that we will reorder columns. _
Then we will feed all data except fist name and surname into master database
    Dim oNhdrWb As Workbook
    Dim oNhdrWs As Worksheet
    
    Dim oWb As Workbook
    Dim oWs As Worksheet
    
    Dim r As Range 'range as a whole
    Dim rHdr As Range 'old header Range
    Dim rNhdr As Range 'New Header range
    Dim rCopy As Range
    Dim rDestination As Range
    
    Dim aNewHdr As Variant 'Array for New Range
    Dim aOldHdr As Variant  'Array for Old Range
    'Dim aE As Variant
    
    Dim i As Integer
    Dim j As Integer
    Dim lr As Integer 'last row in Old
    Dim lc As Integer
    Dim iCntrMissCol As Integer
    
    Dim iNlr As Integer 'last row in New
    Dim iNlc As Integer
    
    Const f As Byte = 1
    
    Dim sNhdrWbFilePath As String
    Dim sOwB As String
    Dim soWsNm As String
    
    Dim bDup As Boolean
    
    sNhdrWbFilePath = Environ("UserProfile") & "\OneDrive\Desktop\New.xlsx"
    sOwB = Environ("UserPorfile") & "\OneDrive\Desktop\Old.xlsm"
    
    On Error Resume Next
    Set oNhdrWb = Workbooks.Open(sNhdrWbFilePath)
    On Error GoTo 0
    Set oNhdrWs = oNhdrWb.Worksheets(1)
    
    Stop 'for testing only
    
    iNlr = oNhdrWs.Cells.Find(What:="*", LookIn:=xlValues, SearchOrder:=xlByRows, SearchDirection:=xlPrevious, MatchCase:=False).Row
    iNlc = oNhdrWs.Cells.Find(What:="*", LookIn:=xlValues, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious, MatchCase:=False).Column
    Set rNhdr = oNhdrWs.Range(oNhdrWs.Cells(f, f), oNhdrWs.Cells(f, iNlc))
    rNhdr.Select
    
    aNewHdr = oNhdrWb.Worksheets("Testing").Range("A1:HH" & iNlc)
    'aNewHdr = rNhdr.Value '<<<<<<<<<<< Question: How to use this line of code instead of line above.Would appreciate any suggestion
    
    
    
    
    Stop
    
    Set oWb = ThisWorkbook
    Set oWs = oWb.Worksheets(1)
    soWsNm = ExtrctStr(sOwB) function to extract original (genuine) name
    oWs.Name = "Test " & soWsNm
    oWs.Activate
    
    lr = oWs.Cells.Find(What:="*", LookIn:=xlValues, SearchOrder:=xlByRows, SearchDirection:=xlPrevious, MatchCase:=False).Row
    lc = oWs.Cells.Find(What:="*", LookIn:=xlValues, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious, MatchCase:=False).Column
    Set rHdr = oWs.Range(oWs.Cells(f, f), oWs.Cells(f, lc))
    rHdr.Select
    
    
    aOldHdr = oWs.Range("A1:EV" & lc)
    'aOldHdr = rHdr.Value '<<<<<<<<<<< Question: How to use this line of code instead of line above. Would appreciate any suggestion

    oWb.Worksheets.Add.Name = "Test"
    Set rDestination = oWb.Worksheets("Test").Range("A1")
    Set r = oWs.Range(oWs.Cells(f, f), oWs.Cells(lr, lc))
    Set rCopy = r
    
    rCopy.Copy Destination:=rDestination
    Application.CutCopyMode = False
    
    Stop
    
    'loop through Array of New column header and compare them to Sheet on ThisWorkbook
    For i = LBound(aOldHdr, 1) To UBound(aOldHdr, 1)
        bDup = False
        For j = LBound(aNewHdr, 1) To UBound(aNewHdr, 1)
            If aOldHdr(1, i) = aNewHdr(1, i) Then
                bDup = True: Debug.Print bDup
            End If
        Next j
        If Not bDup Then
                oWb.Worksheets("Test").Cells(1, i).EntireColumn.Insert 'here i am attempting to understand where I have made mistake
                oWb.Worksheets("Test").Cells(1, i).Value = aNewHdr(1, i)
            'bX = True
             'aOldHdr(1, i) = aNewHdr(1, i)
'            oWs.Cells(1, i).EntireColumn.Insert
            'oWs.Cells(1, i).Interior.ColorIndex = 45
'            oWs.Cells(1, i).Value = aNewHdr(1, i)
            iCntrMissCol = iCntrMissCol + 1
        End If
    Next i
    'If bX = False Then
        'Debug.Print "Items " & i & " identical"
    'End If
    'Debug.Print iCntrMissCol
    
    Stop
    oWb.Close SaveChanges:=True
    oNhdrWb.Close SaveChanges:=True
    
    
End Sub

Public Function ExtrctStr(sExtr As String) As String

    Dim sInput As String
    Dim sOutput As String
    Dim iIntFirst As Integer
    Dim iIntSecond As Integer
    Dim iIntThird As Integer
    
    
    sInput = Environ("UserPorfile") & "\OneDrive\Desktop\Old.xlsm"
    
    iIntFirst = InStr(1, sInput, "\", vbTextCompare)
    iIntSecond = InStr(1, Mid(sInput, iIntFirst + 1), "\", vbTextCompare)
    iIntThird = InStr(1, Mid(sInput, iIntSecond + 2), "\", vbTextCompare)
    If iIntSecond > 0 Then
        iIntSecond = iIntFirst + iIntSecond
    End If
    If iIntThird > 0 Then
        iIntThird = iIntSecond + iIntThird
    End If
        'sOut = Mid(sIn, InStr(3, sIn, "\"), InStr(3, sIn, ".") - 1)
        sOutput = Mid(sInput, (InStr(1, sInput, ".") - 1) - (iIntThird), (InStr(1, sInput, ".") - 1) - (iIntThird))
    
    ExtrctStr = sOutput
    
End Function

 

[DanteAmor]

Hi and welcome to MrExcel!

I would also like to reorder columns in Workbook Old based on patters from Column Header in Workbook New.

In the "old" book do you have information in the rows or do you only have headers?
You want to reorder the columns of the "old" book considering the order of the "new" book, but if data exists, then the entire column must also be reordered.

Both have same Column Headers names (i.e, "ID number", "first name", "Surname", "Date of Birth", "Email", "GP Phone Number" etc), but Workbook "Old" has missing columns which I would like to check against Workbook "New" and populate missing Columns from Workbook "New" to Workbook "Old"

If a column from the "new" book doesn't exist in "old" then we add the column in "old", that's perfectly clear to me. What do we do if a column of "old" does not exist in "new"?

...insert missing columns...

If we insert a "new" column in the "old" book, the column will be empty, I put the header name, but do you need to fill the column with some data?


I await your comments.

 

[Denin Srmic]

Hi and welcome to MrExcel!


In the "old" book do you have information in the rows or do you only have headers?
You want to reorder the columns of the "old" book considering the order of the "new" book, but if data exists, then the entire column must also be reordered.


If a column from the "new" book doesn't exist in "old" then we add the column in "old", that's perfectly clear to me. What do we do if a column of "old" does not exist in "new"?



If we insert a "new" column in the "old" book, the column will be empty, I put the header name, but do you need to fill the column with some data?


I await your comments.

Thanks DanteAmor,

1.Yes I do have information bellow but not in all of them. You are right, I wish to have entire column reordered rather just header based on template of New book, I must have forgotten to mention it. Sorry.
2. Old book does have all the headers from the new book, they are identical, so Header names of Old are indeed the same as in New book just missing considerable number of them.
3. No, missing columns to be inserted are without data save Header names. All rows bellow is empty.

 

[DanteAmor]

Try the following code.
I put the result in a "temp" sheet in the same "old" book so that you can do the revisions.
If all is well, and you want the result to be on the same sheet 1 of the "old" workbook, you can replace these lines:

  On Error Resume Next: wbO.Sheets("temp").Delete: On Error GoTo 0
  wbO.Sheets.Add(after:=wbO.Sheets(wbO.Sheets.Count)).Name = "temp"
  wbO.Sheets("temp").Range("A1").Resize(UBound(b, 1), UBound(b, 2)).Value = b
  wbO.Activate
  Sheets("temp").Select

Along these lines:

  shO.Range("A1").Resize(UBound(b, 1), UBound(b, 2)).Value = b
  wbO.Activate

The macro:

Sub InsertMissingCol()
  Dim shO As Worksheet, shN As Worksheet
  Dim wbO As Workbook, wbN As Workbook
  Dim wbNewName As String
  Dim dic As Object
  Dim a As Variant, b As Variant
  Dim lr As Long, lc As Long, i As Long, j As Long, col As Long, lcNew As Long
  Dim c As Range
  
  Application.DisplayAlerts = False
  Application.ScreenUpdating = False
  
  wbNewName = Environ("UserProfile") & "\OneDrive\Desktop\New.xlsx"
  If Dir(wbNewName) = "" Then
    MsgBox "The 'New.xlsx' file does not exist"
    Exit Sub
  End If
  
  Set wbN = Workbooks.Open(wbNewName)             'open new workbook
  Set shN = wbN.Sheets(1)                         'sheet 1 of new workbook
  Set wbO = ThisWorkbook                          'old book
  Set shO = wbO.Sheets(1)                         'sheet 1 of old book
  Set dic = CreateObject("Scripting.Dictionary")
  
  lr = shO.Cells.Find("*", , xlValues, xlPart, xlByRows, xlPrevious).Row
  lc = shO.Cells.Find("*", , xlValues, xlPart, xlByColumns, xlPrevious).Column
  a = shO.Range("A1", shO.Cells(lr, lc)).Value
  lcNew = shN.Cells(1, Columns.Count).End(1).Column
  ReDim b(1 To UBound(a, 1), 1 To lcNew)
  
  For Each c In shN.Range("A1", shN.Cells(1, lcNew))
    If c.Value <> "" Then
      dic(c.Value) = dic.Count + 1
      b(1, dic.Count) = c.Value
    End If
  Next
  
  For j = 1 To UBound(a, 2)
    col = dic(a(1, j))
    For i = 1 To UBound(a, 1)
      b(i, col) = a(i, j)
    Next
  Next
  
  On Error Resume Next: wbO.Sheets("temp").Delete: On Error GoTo 0
  wbO.Sheets.Add(after:=wbO.Sheets(wbO.Sheets.Count)).Name = "temp"
  wbO.Sheets("temp").Range("A1").Resize(UBound(b, 1), UBound(b, 2)).Value = b
  wbO.Activate
  Sheets("temp").Select
  
  Application.DisplayAlerts = True
  Application.ScreenUpdating = True
End Sub

If you want to know the logic of how to order the columns, check out the following video. Note: use the subtitles, in your language.

 

[Denin Srmic]

Try the following code.
I put the result in a "temp" sheet in the same "old" book so that you can do the revisions.
If all is well, and you want the result to be on the same sheet 1 of the "old" workbook, you can replace these lines:

  On Error Resume Next: wbO.Sheets("temp").Delete: On Error GoTo 0
  wbO.Sheets.Add(after:=wbO.Sheets(wbO.Sheets.Count)).Name = "temp"
  wbO.Sheets("temp").Range("A1").Resize(UBound(b, 1), UBound(b, 2)).Value = b
  wbO.Activate
  Sheets("temp").Select

Along these lines:

  shO.Range("A1").Resize(UBound(b, 1), UBound(b, 2)).Value = b
  wbO.Activate

The macro:

Sub InsertMissingCol()
  Dim shO As Worksheet, shN As Worksheet
  Dim wbO As Workbook, wbN As Workbook
  Dim wbNewName As String
  Dim dic As Object
  Dim a As Variant, b As Variant
  Dim lr As Long, lc As Long, i As Long, j As Long, col As Long, lcNew As Long
  Dim c As Range
 
  Application.DisplayAlerts = False
  Application.ScreenUpdating = False
 
  wbNewName = Environ("UserProfile") & "\OneDrive\Desktop\New.xlsx"
  If Dir(wbNewName) = "" Then
    MsgBox "The 'New.xlsx' file does not exist"
    Exit Sub
  End If
 
  Set wbN = Workbooks.Open(wbNewName)             'open new workbook
  Set shN = wbN.Sheets(1)                         'sheet 1 of new workbook
  Set wbO = ThisWorkbook                          'old book
  Set shO = wbO.Sheets(1)                         'sheet 1 of old book
  Set dic = CreateObject("Scripting.Dictionary")
 
  lr = shO.Cells.Find("*", , xlValues, xlPart, xlByRows, xlPrevious).Row
  lc = shO.Cells.Find("*", , xlValues, xlPart, xlByColumns, xlPrevious).Column
  a = shO.Range("A1", shO.Cells(lr, lc)).Value
  lcNew = shN.Cells(1, Columns.Count).End(1).Column
  ReDim b(1 To UBound(a, 1), 1 To lcNew)
 
  For Each c In shN.Range("A1", shN.Cells(1, lcNew))
    If c.Value <> "" Then
      dic(c.Value) = dic.Count + 1
      b(1, dic.Count) = c.Value
    End If
  Next
 
  For j = 1 To UBound(a, 2)
    col = dic(a(1, j))
    For i = 1 To UBound(a, 1)
      b(i, col) = a(i, j)
    Next
  Next
 
  On Error Resume Next: wbO.Sheets("temp").Delete: On Error GoTo 0
  wbO.Sheets.Add(after:=wbO.Sheets(wbO.Sheets.Count)).Name = "temp"
  wbO.Sheets("temp").Range("A1").Resize(UBound(b, 1), UBound(b, 2)).Value = b
  wbO.Activate
  Sheets("temp").Select
 
  Application.DisplayAlerts = True
  Application.ScreenUpdating = True
End Sub

If you want to know the logic of how to order the columns, check out the following video. Note: use the subtitles, in your language.

Hi DanteAmor, Code works as a charm, this is a masterpiece of VBA engineering!!!


I would want to ask you few things regarding code of yours.

1. Why did you use integer here instead of xlToleft or xlToRight "end.(1)", what does this mean, the whole row? >>>> lcNew = shN.Cells(1, Columns.Count).End(1).Column
2. Would this task have been accomplished without VBA Dictionary Object, meaning using only Arrays? And how? Reason of asking is that I have "covered" VBA Arrays so far, but not yet Collections and Dictionary.
3. Can you please explain in few lines what the two loops are doing, and how they accomplish the task?

Many Thanks for your help and effort, you helped me a lot.

All the Best.

 

[DanteAmor]

1. Why did you use integer here instead of xlToleft or xlToRight "end.(1)"

Just for short:
1 = xlToleft
2 = xlToRight
3 = xlUp = 3
4 = xlDown

2. Would this task have been accomplished without VBA Dictionary Object, meaning using only Arrays?

Yes it is possible.

And how?

col = dic(a(1, j))
That line gets the number of the column position. With arrays you have to iterate through the array one by one to find the position or use some function like match to find the position which will slow down the process.

Reason of asking is that I have "covered" VBA Arrays so far, but not yet Collections and Dictionary.

It is time for you to enter the world of the dictionary.

3. Can you please explain in few lines what the two loops are doing, and how they accomplish the task?

That's exactly why I posted the video.

But in general, the first loop reads the column titles. With the dictionary, locate the position of the "destination" column.
The second loop reads the data from the rows in the "source" column and moves it to the "destination" column.


I hope that helps.

 

[Denin Srmic]

Just for short:
1 = xlToleft
2 = xlToRight
3 = xlUp = 3
4 = xlDown


Yes it is possible.



col = dic(a(1, j))
That line gets the number of the column position. With arrays you have to iterate through the array one by one to find the position or use some function like match to find the position which will slow down the process.



It is time for you to enter the world of the dictionary.



That's exactly why I posted the video.

But in general, the first loop reads the column titles. With the dictionary, locate the position of the "destination" column.
The second loop reads the data from the rows in the "source" column and moves it to the "destination" column.


I hope that helps.

Thank you again for taking time providing the code and shedding light into it how it works. Yes indeed, I watched you video, and to be honest, I will have to go through couple of times after I have acquainted myself with VBA Dictionary object. It's amazing what one can achieve with VBA. I think that your statement is completely right, I have to enter the world of VBA Dictionary object.
All the best