VBA: text recognition - copy specific columns from sheet1 to sheet2 - excel

Question

a kind soul made me this code for another question i asked. But im thinking about text recognition. So i got a data input in sheet1, there is some headers for each column in the data input, and i want to sort by specific header names, copy them, and paste the two rows of the columns which header matches my keywords, in sheet2. Pasting the data in sheet2, should be at the first two lines available, like here in my code already. Really want to keep most of the code as possible and then maybe only change the sub where i copy the two rows in a specific range. Would appreciate the help:)
Option Explicit
Sub call_copy_sub_ranges()
Dim ws1 As Worksheet, wsOut As Worksheet
Set ws1 = ThisWorkbook.Worksheets("Ark1")
Set wsOut = ThisWorkbook.Worksheets("Ark2")
Dim ar
ar = Array("HeaderA", "HeaderB", "HeaderC", "HeaderD", "HeaderE", _
"HeaderF", "HeaderG", "HeaderH", "HeaderI", "HeaderJ", "HeaderK", _
"HeaderL", "HeaderM", "HeaderN", "HeaderO", "HeaderP", "HeaderQ", _
"HeaderR", "HeaderS", "HeaderT", "HeaderU", "HeaderV", "HeaderW", _
"HeaderX", "HeaderY", "HeaderZ", "HeaderAA", "HeaderAB", "HeaderAC", _
"HeaderAD", "HeaderAE", "HeaderAF", "HeaderAG", "HeaderAH", "HeaderAI", _
"HeaderAJ", "HeaderAK", "HeaderAL", "HeaderAM", "HeaderAN", "HeaderAO", _
"HeaderAP", "HeaderAQ", "HeaderAR", "HeaderAS", "HeaderAT", "HeaderAU", _
"HeaderAV", "HeaderAW", "HeaderAX", "HeaderAY")
wsOut.Range("A1:AY1").Value = ar
copy_sub_ranges ws1, wsOut
MsgBox "Done"
End Sub
Sub copy_sub_ranges(ByVal ws1 As Worksheet, ByVal wsOut As Worksheet)
Dim rng As Range, rngOut As Range, ar, s
ar = Array("S2:S3", "BF7:BH8", "BI9:CC10", _
"CD9:CQ9", "CR9:CS10", "CT9:CV9", "CW9:CW10", "CX10", "EE9:EI10")
' target
Set rngOut = wsOut.Cells(wsOut.Rows.Count, 1).End(xlUp)
If Not IsEmpty(wsOut.Range("A1").Text) Then
Set rngOut = rngOut.offset(1, 0)
End If
For Each s In ar
Set rng = ws1.Range(s)
Debug.Print rng.Address, rngOut.Address
rng.Copy rngOut
Set rngOut = rngOut.offset(0, rng.Columns.Count)
Next
' underline
Set rng = wsOut.Cells(wsOut.Rows.Count, 1).End(xlUp)
With rng.Resize(1, rngOut.Column - 1).Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 0
.Weight = xlMedium
End With
End Sub

Answer 1

You could execute an SQL statement on your worksheet, or on a range within the worksheet. This would allow you to trivially select only specific columns, and sort by specific columns.
Add a reference (Tools -> References...) to Microsoft ActiveX Data Objects; choose the latest version (usually 6.1).
Then you could write code similar to the following:
Dim sql As String
sql = _
"SELECT HeaderA, HeaderG, HeaderP " & _
"FROM [Sheet1$] " & _
"ORDER BY HeaderQ, HeaderR"
' If your data is only in a specific range, you can limit to that range:
'sql = _
' "SELECT HeaderA, HeaderG, HeaderP " & _
' "FROM [Sheet1$B5:AA17] " & _
' "ORDER BY HeaderQ, HeaderR"
Const filepath As String = "C:\path\to\excel\file.xlsx"
Dim connectionString As String
connectionString = _
"Provider=Microsoft.ACE.OLEDB.12.0;" & _
"Data Source=""" & filepath & """;" & _
"Extended Properties=""Excel 12.0;HDR=Yes"""
Dim rs As New ADODB.Recordset
rs.Open sql, connectionString
ThisWorkbook.Worksheets("Ark2").Range("A1").CopyFromRecordset rs
Note that there's nothing preventing you from using an array of strings as the selected columns, or as the sort fields; use the Join function to combine the field names into a comma-separated string:
Dim fieldnames() As String
fieldnames = Array("HeaderB", "HeaderC", "HeaderD")
Dim sortnames() As String
sortnames = Array("HeaderM", "HeaderN", "HeaderO")
sql = _
"SELECT " & Join(fieldnames, ", ") & " " & _
"FROM [Sheet1$] " & _
"ORDER BY " & Join(sortnames, ", ")
fieldnames and sortnames could be populated from different cells:
Dim sheet As Worksheet
Set sheet = Worksheets("Sheet1")
fieldnames = Array(sheet.Range("A1").Value, sheet.Range("B1").Value))