Copy columns based on header and array

ijhoeq

Board Regular
Joined
Jun 20, 2018
Messages
61
Hello,

I have data in Sheet1 that I'd like to copy into Sheet2 based on the header. I'd like to create some kind of text array that I can update in the code to include new columns if they become relevant. I'd like the relevant headers array to be something like

sWords = {"Date", "Qty", "Method"}.

Then I can add new words if I need to (Example: sWords = {"Date", "Qty", "Method", "Quality"}).

I would like the words in the sWords array to be the search criteria for copy and paste. The words could be searched for in Sheet1 Row 1. I'm sure there is a way to do this with a For Loop or something but I am new to VBA.

In Sheet1, I have the data below.

ABCDE
1Date
QtyCompleteMethodQuality
21/5/1825Yes1High
33/10/1910N2Medium

<tbody>
</tbody>

I'd like to be able to copy the headers in the sWord array and paste it into Sheet2.

For example, in the code, if I set sWord = {"Qty", "Method"}

I'd like Sheet2 to display the table below

AB
1Qty
Method
2251
3102

<tbody>
</tbody>

I hope I explained this well enough. I'd appreciate any help! Thanks!
 

Excel Facts

Convert text numbers to real numbers
Select a column containing text numbers. Press Alt+D E F to quickly convert text to numbers. Faster than "Convert to Number"
How about

Rich (BB code):
Sub ijhoeq()
   Dim Ary As Variant
   Dim i As Long
   Dim Fnd As Range
   
   Ary = Array("Date", "Qty", "Method")
   With Sheets("Sheet1")
      For i = 0 To UBound(Ary)
         Set Fnd = .Range("1:1").Find(Ary(i), , , xlWhole, , , False, , False)
         If Not Fnd Is Nothing Then
            Fnd.EntireColumn.Copy Sheets("Sheet2").Cells(1, i + 1)
         End If
      Next i
   End With
End Sub
 
Upvote 0
Try this.
Code:
Dim sWords As Variant
Dim Res As Variant
Dim idx As Long
Dim idxCol As Long
Dim cnt As Long

    sWords = Array("Date", "Qty", "Method")
    
    With Sheets("Sheet1")
        Res = Application.Match(sWords, .Rows(1), 0)
        
        For idx = LBound(Res) To UBound(Res)
            If Not IsError(Res(idx)) Then
                cnt = cnt + 1
                idxCol = Res(idx)
                .Columns(idxCol).Copy Sheets("Sheet2").Columns(cnt)
            End If
        Next idx
    End With
 
Upvote 0
Thanks for the help! I went with Fluff's method. I just have one more issue... The data starts on row 3 so I adjusted the code and it works great but it pastes into sheet2 on row 3. Could you tell me how to paste it into row 1 on sheet2?

Thanks!
 
Upvote 0
What is your adjusted code?
 
Upvote 0
Code:
    Dim Ary As Variant
    Dim i As Long
    Dim Fnd As Range
    
    ' Ary is the array that contains all words to search for and copy
    Ary = Array("JC", "Event Date", "MC", "Removed Part", "Installed Part", _
                "Production Number", "Number", "Score", "Board Score", _
                "TC", "AT", "WD", "MAL", "AAA Mode", "Failure", "Maintenance")
    With Sheets("Search Results")
        For i = 0 To UBound(Ary)
            Set Fnd = .Range("3:3").Find(Ary(i), , , xlWhole, , , False, , False)
            If Not Fnd Is Nothing Then
                Fnd.EntireColumn.Copy Sheets("Filtered Data").Cells(1, i + 1)
            End If
        Next i
    End With

Also, is there any way to copy the data to the last row instead of the entire column? I have a lot of data and I believe it is running very slow since it is copying the entire column.

Thanks Fluff!!
 
Last edited:
Upvote 0
How about
Rich (BB code):
Sub ijhoeq()
    Dim Ary As Variant
    Dim i As Long
    Dim Fnd As Range
    
    ' Ary is the array that contains all words to search for and copy
    Ary = Array("JC", "Event Date", "MC", "Removed Part", "Installed Part", _
                "Production Number", "Number", "Score", "Board Score", _
                "TC", "AT", "WD", "MAL", "AAA Mode", "Failure", "Maintenance")
    With Sheets("Search Results")
        For i = 0 To UBound(Ary)
            Set Fnd = .Range("3:3").Find(Ary(i), , , xlWhole, , , False, , False)
            If Not Fnd Is Nothing Then
                .Range(Fnd, .Cells(Rows.Count, Fnd.Column).End(xlUp)).Copy Sheets("Filtered Data").Cells(1, i + 1)
            End If
        Next i
    End With
End Sub
 
Last edited:
Upvote 0
Glad to help & thanks for the feedback
 
Upvote 0

Forum statistics

Threads
1,213,533
Messages
6,114,179
Members
448,554
Latest member
Gleisner2

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