Copy columns based on header and array

[ijhoeq]

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.

[TABLE="class: grid, width: 500"]
<tbody>[TR]
[TD][/TD]
[TD]A[/TD]
[TD]B[/TD]
[TD]C[/TD]
[TD]D[/TD]
[TD]E[/TD]
[/TR]
[TR]
[TD]1[/TD]
[TD]Date
[/TD]
[TD]Qty[/TD]
[TD]Complete[/TD]
[TD]Method[/TD]
[TD]Quality[/TD]
[/TR]
[TR]
[TD]2[/TD]
[TD]1/5/18[/TD]
[TD]25[/TD]
[TD]Yes[/TD]
[TD]1[/TD]
[TD]High[/TD]
[/TR]
[TR]
[TD]3[/TD]
[TD]3/10/19[/TD]
[TD]10[/TD]
[TD]N[/TD]
[TD]2[/TD]
[TD]Medium[/TD]
[/TR]
</tbody>[/TABLE]

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

[TABLE="class: grid, width: 200"]
<tbody>[TR]
[TD][/TD]
[TD]A[/TD]
[TD]B[/TD]
[/TR]
[TR]
[TD]1[/TD]
[TD]Qty
[/TD]
[TD]Method
[/TD]
[/TR]
[TR]
[TD]2[/TD]
[TD]25[/TD]
[TD]1[/TD]
[/TR]
[TR]
[TD]3[/TD]
[TD]10[/TD]
[TD]2[/TD]
[/TR]
</tbody>[/TABLE]

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

 

[Fluff]

How about


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

 

[Norie]

Try this.

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

 

[ijhoeq]

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!

 

[Fluff]

What is your adjusted code?

 

[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
                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!!

 

[Fluff]

How about

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

 

[ijhoeq]

Thanks that works great!

 

[Fluff]

Glad to help & thanks for the feedback