VBA Copy columns based on list of headers and paste into another sheets. Columns paste into wrong target range

R

radsok8199

New Member
Joined
Dec 4, 2020
Messages
24
Office Version
  1. 2016
Platform
  1. Windows
  2. MacOS
  3. Mobile
Dear VVA Masters

I have below code to find columns based on headers and paste them into new created sheet.
First rows are merged. A1:B1, And C1 : to the end of values.
At first this code will copy entire column A and B and paste into new sheet. I t works fine
Second it should find columns with headers from Array and paste into new worksheet right after columns A & B. It does find columns and paste them into new worksheet keeping all formats, however it does paste copied columns into new sheet but different range. It paste into A1 overwriting previously pasted here columns. Not sure why it does not work ?

VBA Code: 
Sub GetColumnsByHeader()

Application.ScreenUpdating = False

Dim newSht As Worksheet, ws As Worksheet, Hdrs As Variant, i As Long, Fnd As Range, lcolS As Long, wb As Workbook, rng As Range
Dim lr As Long, lrnewSht As Long
    Set wb = ThisWorkbook
        Set ws = wb.Sheets("SM mode")
            lcolS = ws.Cells(10, 3).End(xlToRight).Column
                lr = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
                    Set newSht = wb.Sheets.Add(After:=wb.Sheets(wb.Sheets.Count))
                    newSht.Name = "Admin 1_6"
                        Set rng = ws.Range(ws.Cells(1, 1), ws.Cells(lr, lcolS))
                       
ws.Range(ws.Cells(1, "A"), ws.Cells(lr, "B")).Copy

        With newSht.Range("A1")
            .PasteSpecial Paste:=xlPasteValuesAndNumberFormats
            .PasteSpecial Paste:=xlPasteColumnWidths
            .PasteSpecial Paste:=xlPasteFormats
            Application.CutCopyMode = False
        End With
       
'lrnewSht = newSht.Cells(10, 1).End(xlToRight).Column

Hdrs = Array("Admin 1", "Admin 2", "Admin 3", "Admin 4", "Admin 5", "Admin 6")

With ws.Range(ws.Cells(2, 3), ws.Cells(2, lcolS))
    For i = LBound(Hdrs) To UBound(Hdrs)
        Set Fnd = .Find(Hdrs(i), lookat:=xlWhole)
                If Not Fnd Is Nothing Then
                        Intersect(Fnd.EntireColumn, rng).Copy
                        newSht.Cells(1,  2+ i).PasteSpecial Paste:=xlPasteValuesAndNumberFormats
                        newSht.Cells(1,  2+ i).PasteSpecial Paste:=xlPasteColumnWidths
                        newSht.Cells(1,  2+ i).PasteSpecial Paste:=xlPasteFormats
                End If
            Next i
    Application.CutCopyMode = False
   
End With

Application.ScreenUpdating = True
End Sub

I also tried as below

VBA Code: 
Sub GetColumnsByHeader()

Application.ScreenUpdating = False

Dim newSht As Worksheet, ws As Worksheet, Hdrs As Variant, i As Long, Fnd As Range, lcolS As Long, wb As Workbook, rng As Range
Dim lr As Long, lrnewSht As Long
    Set wb = ThisWorkbook
        Set ws = wb.Sheets("SM mode")
            lcolS = ws.Cells(10, 3).End(xlToRight).Column
                lr = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
                    Set newSht = wb.Sheets.Add(After:=wb.Sheets(wb.Sheets.Count))
                    newSht.Name = "Admin 1_6"
                        Set rng = ws.Range(ws.Cells(1, 1), ws.Cells(lr, lcolS))
                       
ws.Range(ws.Cells(1, "A"), ws.Cells(lr, "B")).Copy

        With newSht.Range("A1")
            .PasteSpecial Paste:=xlPasteValuesAndNumberFormats
            .PasteSpecial Paste:=xlPasteColumnWidths
            .PasteSpecial Paste:=xlPasteFormats
            Application.CutCopyMode = False
        End With
       
lrnewSht = newSht.Cells(10, 1).End(xlToRight).Column

Hdrs = Array("Admin 1", "Admin 2", "Admin 3", "Admin 4", "Admin 5", "Admin 6")

With ws.Range(ws.Cells(2, 3), ws.Cells(2, lcolS))
    For i = LBound(Hdrs) To UBound(Hdrs)
        Set Fnd = .Find(Hdrs(i), lookat:=xlWhole)
                If Not Fnd Is Nothing Then
                        Intersect(Fnd.EntireColumn, rng).Copy
                        newSht.Cells(1, lrnewSht + i).PasteSpecial Paste:=xlPasteValuesAndNumberFormats
                        newSht.Cells(1, lrnewSht + i).PasteSpecial Paste:=xlPasteColumnWidths
                        newSht.Cells(1, lrnewSht + i).PasteSpecial Paste:=xlPasteFormats
                End If
            Next i
    Application.CutCopyMode = False
   
End With

Application.ScreenUpdating = True
End Sub

Below screen from sheets

1617186012804.png
 
Last edited:

Excel Facts

Quick Sum
Select a range of cells. The total appears in bottom right of Excel screen. Right-click total to add Max, Min, Count, Average.
Sort by date Sort by votes
radsok8199 said:
Dear VVA Masters

I have below code to find columns based on headers and paste them into new created sheet.
First rows are merged. A1:B1, And C1 : to the end of values.
At first this code will copy entire column A and B and paste into new sheet. I t works fine
Second it should find columns with headers from Array and paste into new worksheet right after columns A & B. It does find columns and paste them into new worksheet keeping all formats, however it does paste copied columns into new sheet but different range. It paste into A1 overwriting previously pasted here columns. Not sure why it does not work ?

VBA Code: 
Sub GetColumnsByHeader()

Application.ScreenUpdating = False

Dim newSht As Worksheet, ws As Worksheet, Hdrs As Variant, i As Long, Fnd As Range, lcolS As Long, wb As Workbook, rng As Range
Dim lr As Long, lrnewSht As Long
    Set wb = ThisWorkbook
        Set ws = wb.Sheets("SM mode")
            lcolS = ws.Cells(10, 3).End(xlToRight).Column
                lr = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
                    Set newSht = wb.Sheets.Add(After:=wb.Sheets(wb.Sheets.Count))
                    newSht.Name = "Admin 1_6"
                        Set rng = ws.Range(ws.Cells(1, 1), ws.Cells(lr, lcolS))
                      
ws.Range(ws.Cells(1, "A"), ws.Cells(lr, "B")).Copy

        With newSht.Range("A1")
            .PasteSpecial Paste:=xlPasteValuesAndNumberFormats
            .PasteSpecial Paste:=xlPasteColumnWidths
            .PasteSpecial Paste:=xlPasteFormats
            Application.CutCopyMode = False
        End With
      
'lrnewSht = newSht.Cells(10, 1).End(xlToRight).Column

Hdrs = Array("Admin 1", "Admin 2", "Admin 3", "Admin 4", "Admin 5", "Admin 6")

With ws.Range(ws.Cells(2, 3), ws.Cells(2, lcolS))
    For i = LBound(Hdrs) To UBound(Hdrs)
        Set Fnd = .Find(Hdrs(i), lookat:=xlWhole)
                If Not Fnd Is Nothing Then
                        Intersect(Fnd.EntireColumn, rng).Copy
                        newSht.Cells(1,  2+ i).PasteSpecial Paste:=xlPasteValuesAndNumberFormats
                        newSht.Cells(1,  2+ i).PasteSpecial Paste:=xlPasteColumnWidths
                        newSht.Cells(1,  2+ i).PasteSpecial Paste:=xlPasteFormats
                End If
            Next i
    Application.CutCopyMode = False
  
End With

Application.ScreenUpdating = True
End Sub

I also tried as below

VBA Code: 
Sub GetColumnsByHeader()

Application.ScreenUpdating = False

Dim newSht As Worksheet, ws As Worksheet, Hdrs As Variant, i As Long, Fnd As Range, lcolS As Long, wb As Workbook, rng As Range
Dim lr As Long, lrnewSht As Long
    Set wb = ThisWorkbook
        Set ws = wb.Sheets("SM mode")
            lcolS = ws.Cells(10, 3).End(xlToRight).Column
                lr = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
                    Set newSht = wb.Sheets.Add(After:=wb.Sheets(wb.Sheets.Count))
                    newSht.Name = "Admin 1_6"
                        Set rng = ws.Range(ws.Cells(1, 1), ws.Cells(lr, lcolS))
                      
ws.Range(ws.Cells(1, "A"), ws.Cells(lr, "B")).Copy

        With newSht.Range("A1")
            .PasteSpecial Paste:=xlPasteValuesAndNumberFormats
            .PasteSpecial Paste:=xlPasteColumnWidths
            .PasteSpecial Paste:=xlPasteFormats
            Application.CutCopyMode = False
        End With
      
lrnewSht = newSht.Cells(10, 1).End(xlToRight).Column

Hdrs = Array("Admin 1", "Admin 2", "Admin 3", "Admin 4", "Admin 5", "Admin 6")

With ws.Range(ws.Cells(2, 3), ws.Cells(2, lcolS))
    For i = LBound(Hdrs) To UBound(Hdrs)
        Set Fnd = .Find(Hdrs(i), lookat:=xlWhole)
                If Not Fnd Is Nothing Then
                        Intersect(Fnd.EntireColumn, rng).Copy
                        newSht.Cells(1, lrnewSht + i).PasteSpecial Paste:=xlPasteValuesAndNumberFormats
                        newSht.Cells(1, lrnewSht + i).PasteSpecial Paste:=xlPasteColumnWidths
                        newSht.Cells(1, lrnewSht + i).PasteSpecial Paste:=xlPasteFormats
                End If
            Next i
    Application.CutCopyMode = False
  
End With

Application.ScreenUpdating = True
End Sub

Below screen from sheets

View attachment 35664
Click to expand...
I found issue, I forgot that Array index numbers begins from 0 instead 1. So i = 0 and then so on 1, 2 , 3 :) Hope this help someone :)
 
Upvote 0
Solution
You must log in or register to reply here.

Similar threads

C
  • Solved
Copy paste columns based on matching header into another workbook
Replies
5
Views
327
mumps
mumps
V
  • Solved
Need VBA to split data into multiple sheets paste formulas, formatting AND data validation
Replies
2
Views
126
vanessavalentino83
V
H
  • Solved
Splitting Data into Workbooks - EDIT HELP
Replies
1
Views
291
horrellbt01
H
R
  • Question Question
[VBA] - Need to Hide one column and need sum of columns
Replies
0
Views
197
rsolanki
R
S
  • Question Question
Parse data - Overwrite lines with updated data
Replies
0
Views
343
Scifo
S

Forum statistics

Threads
1,224,829
Messages
6,181,218
Members
453,024
Latest member
Wingit77

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top