VBA - Copy specific headers help... check point

Mallesh23

Active Member
Joined
Feb 4, 2009
Messages
336
Office Version
2010
Platform
Windows
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
 
Last edited:

Some videos you may like

Excel Facts

Can you sort left to right?
To sort left-to-right, use the Sort dialog box. Click Options. Choose "Sort left to right"

gallen

Well-known Member
Joined
Jun 27, 2011
Messages
1,996
If i undertsand correctly:

Code:
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

Active Member
Joined
Feb 4, 2009
Messages
336
Office Version
2010
Platform
Windows
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

Well-known Member
Joined
Dec 3, 2018
Messages
11,939
Office Version
2007
Platform
Windows
Looking for another thread, I found this, I hope it still works for you.

VBA Code:
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

Active Member
Joined
Feb 4, 2009
Messages
336
Office Version
2010
Platform
Windows
Hi Danteamor,

Thanks for your help, its working. 🕺

Regards
mg
 

DanteAmor

Well-known Member
Joined
Dec 3, 2018
Messages
11,939
Office Version
2007
Platform
Windows
I'm glad to help you. Thanks for the feedback.
 

Watch MrExcel Video

Forum statistics

Threads
1,100,140
Messages
5,472,751
Members
406,835
Latest member
steve43040

This Week's Hot Topics

Top