VBA - Copy Multiple Columns as per mapping sheet union help

[malleshg24]

Hi Team,


Need your help , Task involve Copy of multiple Columns as per header in mapping sheet
and pasting in Output sheet. usually there will be 20 Columns out 40 Columns. which needs to copy paste.


if any specific columns missing intimate those headers to the user the and exit sub.
Attached are my sample workbook. plz assist and Thanks for your help in advance !!!



ub Copy_Specific_Column()

Dim lr As Long, i As Long, a As Variant, C As Range
lr = Sheet1.Range("A" & Rows.Count).End(xlUp).Row
Set r = sheet1.Range("A" & lr + 1) '

a = Sheet1.Range("A2:A" & lr).Value

For i = 1 To UBound(a)
On Error Resume Next
r = Sheet2.Rows("1:1").Find(What:=a(i), After:=ActiveCell, LookIn:=xlValues, LookAt _
:=xlWhole, SearchOrder:=xlByColumns, SearchDirection:=xlNext)
On Error GoTo 0
If Not r Is Nothing Then
r = Union(r, r)
Else
MsgBox ' header Not found
End If
Next i

r.copy sheets("Output").range("a1")


Thanks
mg

[Kenneth Hobs]

Your approach is similar to what I would do. If I showed a MsgBox, it would just be one at the end.

Tweaking your code:

Sub Copy_Specific_Column()
Dim lr As Long, i As Long, a As Variant, C As Range
Dim rr As Range, r As Range, iR As Range

lr = Sheet1.Range("A" & Rows.Count).End(xlUp).Row
a = Sheet1.Range("A2:A" & lr).Value
Set iR = Sheet2.Cells(1, Sheet2.Columns.Count).End(xlToLeft)

For i = 1 To UBound(a)
Set r = Sheet2.Range("A1", iR).Find(What:=a(i, 1), After:=iR, _
LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByColumns, SearchDirection:=xlNext)
If r Is Nothing Then
MsgBox a(i, 1) & " was not found." ' header Not found"
GoTo NextI
End If
Set r = Intersect(r.EntireColumn, Sheet2.UsedRange)
If rr Is Nothing Then
Set rr = r
Else
Set rr = Union(rr, r)
End If
NextI:
Next i

If rr Is Nothing Then Exit Sub
'check all headers and paste in output sheet.
rr.Copy Worksheets("Output").Range("A1")
End Sub

[Paul_Hossler]

Essentially the same, but I corrected the Output WS name



Option Explicit
Sub Copy_Specific_Column_PH()

Dim oWSF As Object
Dim r As Range
Dim vMap As Variant, vIn As Variant
Dim iMap As Long, iIn As Long, iOut As Long

Set oWSF = Application.WorksheetFunction

With Worksheets("Mapping")
Set r = Range(.Cells(2, 1), .Cells(2, 1).End(xlDown))
vMap = oWSF.Transpose(r.Value)
End With

With Worksheets("Input")
Set r = Range(.Cells(1, 1), .Cells(1, 1).End(xlToRight))
vIn = oWSF.Transpose(oWSF.Transpose(r.Value))
End With

For iMap = LBound(vMap) To UBound(vMap)
On Error Resume Next
iIn = 0
iIn = oWSF.Match(vMap(iMap), vIn, 0)
On Error GoTo 0
If iIn = 0 Then
MsgBox vMap(iMap) & " not found on Input"
Exit Sub
End If
Next iMap

For iMap = LBound(vMap) To UBound(vMap)
iIn = oWSF.Match(vMap(iMap), vIn, 0)
Worksheets("Input").Columns(iIn).Copy Worksheets("Output").Columns(iMap)
Next iMap

End Sub

[mana]

Option Explicit


Sub test()
Dim dic As Object
Dim tbl As Range
Dim r As Range, c As Range
Dim m
Dim msg As String

Set dic = CreateObject("scripting.dictionary")
Set tbl = Sheets("Input").Cells(1).CurrentRegion
Set r = Sheets("Mapping").Cells(1).CurrentRegion

For Each c In Intersect(r, r.Offset(1))
m = Application.Match(c, tbl.Rows(1), 0)
If IsNumeric(m) Then
dic(m) = Application.Transpose(tbl.Columns(m))
Else
msg = msg & vbLf & c.Value
End If
Next

If Len(msg) Then MsgBox "header Not found:" & vbLf & msg

With Sheets("Output")
.Cells(1).CurrentRegion.ClearContents
.Cells(1).Resize(tbl.Rows.Count, dic.Count).Value = _
Application.Transpose(dic.items)
.Select
End With

End Sub

[mana]

Sub test2()
Dim dic As Object
Dim tbl As Range
Dim r As Range, c As Range
Dim msg As String

Set dic = CreateObject("scripting.dictionary")
Set tbl = Sheets("Input").Cells(1).CurrentRegion
Set r = Sheets("Mapping").Cells(1).CurrentRegion

For Each c In Intersect(r, r.Offset(1))
If WorksheetFunction.CountIf(tbl.Rows(1), c.Value) Then
dic(dic.Count) = c.Value
Else
msg = msg & vbLf & c.Value
End If
Next

If Len(msg) Then MsgBox "header Not found:" & vbLf & msg

With Sheets("Output")
.Cells(1).CurrentRegion.ClearContents
.Cells(1).Resize(, dic.Count).Value = dic.items
tbl.AdvancedFilter xlFilterCopy, , .Cells(1).Resize(, dic.Count)
.Select
End With

End Sub

[malleshg24]

Kenneth,Paul,Mana,


Superb !:clap:
Thank you all for your help and sharing different solution for my Question.
I will practise on this.Thanks


Regards,
mg