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

How to show all formulas in Excel?
Press Ctrl+` to show all formulas. Press it again to toggle back to numbers. The grave accent is often under the tilde on US keyboards.
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

S
  • Question
Parse data - Overwrite lines with updated data
Replies
0
Views
123
Scifo
S
R
  • Solved
VBA: Merging columns based on header
2
Replies
12
Views
624
ruinedelf
R
H
  • Solved
Excel VBA file importing data from several files located in same folder -> challenge to copy data only (rest is working perfectly)
Replies
3
Views
135
NdNoviceHlp
NdNoviceHlp
E
  • Question
Trying to use index match method
Replies
7
Views
550
RoryA
RoryA
S
  • Solved
Working with multiple Target Ranges in Worksheet Code
Replies
3
Views
375
sspatriots
S

Forum statistics

Threads
1,214,971
Messages
6,122,525
Members
449,088
Latest member
RandomExceller01

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