VBA - Copy specific headers help... check point

[Mallesh23]

Hi Team


I got one vba solution on this site given by DanteAmor,
if any header missing then I want to add message box for user and exit sub


Option Explicit


Sub copy_paste_data_based_column_headers()
Dim sh1 As Worksheet, sh2 As Worksheet, a() As Variant, b() As Variant
Dim i As Long, j As Long, lr As Long, lc As Long, lr2 As Long

Set sh1 = Sheets("Sheet1") 'origin
Set sh2 = Sheets("Sheet2") 'destination

'last row on origin sheet
lr = sh1.Range("A" & Rows.Count).End(xlUp).Row
'last row on destination sheet
lr2 = sh2.Range("A" & Rows.Count).End(xlUp).Row + 1

'Store headers in the "a" variable of the origin sheet
lc = sh1.Cells(1, Columns.Count).End(xlToLeft).Column
a = WorksheetFunction.Transpose(sh1.Range("A1", sh1.Cells(1, lc)).Value)


'Store headers in the "b" variable of the destination sheet
lc = sh2.Cells(1, Columns.Count).End(xlToLeft).Column
b = WorksheetFunction.Transpose(sh2.Range("A1", sh2.Cells(1, lc)).Value)

For i = 1 To UBound(a, 1)
For j = 1 To UBound(b, 1)


'Compare header
If b(j, 1) = a(i, 1) Then
'copy the column
sh2.Cells(lr2, j).Resize(lr).Value = sh1.Cells(2, i).Resize(lr).Value
Exit For
End If
Next
Next
MsgBox "End"
End Sub

Regards
mg

 

[gallen]

If i undertsand correctly:

Sub copy_paste_data_based_column_headers()
 
    Dim sh1 As Worksheet, sh2 As Worksheet, a() As Variant, b() As Variant
    Dim i As Long, j As Long, lr As Long, lc As Long, lr2 As Long
    [COLOR=#ff0000]Dim cel As Range[/COLOR]
    
    Set sh1 = Sheets("Sheet1") 'origin
    Set sh2 = Sheets("Sheet2") 'destination
    
    'last row on origin sheet
    lr = sh1.Range("A" & Rows.Count).End(xlUp).Row
    'last row on destination sheet
    lr2 = sh2.Range("A" & Rows.Count).End(xlUp).Row + 1
    
    'Store headers in the "a" variable of the origin sheet
    lc = sh1.Cells(1, Columns.Count).End(xlToLeft).Column
    a = WorksheetFunction.Transpose(sh1.Range("A1", sh1.Cells(1, lc)).Value)
    
[COLOR=#ff0000]    For Each cel In sh1.Range("A1", sh1.Cells(1, lc))
        If Len(Trim(cel.Value)) = 0 Then
            MsgBox "Blank Header at " & cel.Address, vbCritical, "No Header"
            Exit Sub
        End If
    Next cel[/COLOR]
    
    'Store headers in the "b" variable of the destination sheet
    lc = sh2.Cells(1, Columns.Count).End(xlToLeft).Column
    b = WorksheetFunction.Transpose(sh2.Range("A1", sh2.Cells(1, lc)).Value)
    
[COLOR=#ff0000]    For Each cel In sh2.Range("A1", sh1.Cells(1, lc))
        If Len(Trim(cel.Value)) = 0 Then
            MsgBox "Blank Header at " & cel.Address, vbCritical, "No Header"
            Exit Sub
        End If
    Next cel[/COLOR]
    
    For i = 1 To UBound(a, 1)
        For j = 1 To UBound(b, 1)
            'Compare header
            If b(j, 1) = a(i, 1) Then
            'copy the column
            sh2.Cells(lr2, j).Resize(lr).Value = sh1.Cells(2, i).Resize(lr).Value
            Exit For
            End If
        Next
    Next
    MsgBox "End"
End Sub

 

[Mallesh23]

Hi Gallen and Team,


Thanks for the help, Actually I am looking checkpoint here. if value not found from one array to another array. like as below.
If b(j, 1) <> a(i, 1) Then msgbox header b(j,1) not found. plz check header and exit sub.

Thanks for your help in advance !

Regards,
mg

 

[DanteAmor]

Looking for another thread, I found this, I hope it still works for you.

Sub copy_paste_data_based_column_headers()
  Dim sh1 As Worksheet, sh2 As Worksheet, a() As Variant, b() As Variant
  Dim i As Long, j As Long, lr As Long, lc As Long, lr2 As Long
  Dim exists As Boolean
  
  Set sh1 = Sheets("Sheet1") 'origin
  Set sh2 = Sheets("Sheet2") 'destination
  
  'last row on origin sheet
  lr = sh1.Range("A" & Rows.Count).End(xlUp).Row
  'last row on destination sheet
  lr2 = sh2.Range("A" & Rows.Count).End(xlUp).Row + 1
  
  'Store headers in the "a" variable of the origin sheet
  lc = sh1.Cells(1, Columns.Count).End(xlToLeft).Column
  a = WorksheetFunction.Transpose(sh1.Range("A1", sh1.Cells(1, lc)).Value)
  
  
  'Store headers in the "b" variable of the destination sheet
  lc = sh2.Cells(1, Columns.Count).End(xlToLeft).Column
  b = WorksheetFunction.Transpose(sh2.Range("A1", sh2.Cells(1, lc)).Value)
  
  For i = 1 To UBound(a, 1)
    exists = False
    For j = 1 To UBound(b, 1)
      'Compare header
      If b(j, 1) = a(i, 1) Then
        'copy the column
        sh2.Cells(lr2, j).Resize(lr).Value = sh1.Cells(2, i).Resize(lr).Value
        exists = True
        Exit For
      End If
    Next
    If exists = False Then
      MsgBox "header " & a(i, 1) & " not found. plz check header"
      Exit Sub
    End If
  Next
  MsgBox "End"
End Sub

 

[Mallesh23]

Hi Danteamor,

Thanks for your help, its working. ?

Regards
mg

 

[DanteAmor]

I'm glad to help you. Thanks for the feedback.