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

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

What did Pito Salas invent?
Pito Salas, working for Lotus, popularized what would become to be pivot tables. It was released as Lotus Improv in 1989.

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

View attachment 35664
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 :)
 
Solution

Watch MrExcel Video

Forum statistics

Threads
1,130,102
Messages
5,640,112
Members
417,126
Latest member
Jeffman52

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
Top