Excel vba：按照标题提取需求的列信息

ZHLK

原始表标题行改一下名
Private Sub CommandButton1_Click()

Application.ScreenUpdating = False
Rows("2:20000").Delete
    aa = Range("a65320").End(xlUp).Row + 1
        With ActiveSheet.ListObjects.Add(SourceType:=0, Source:= _
            "ODBC;DSN=Excel Files;DBQ=" & ThisWorkbook.fullname & ";" _
            , Destination:=Range("$A$" & aa)).QueryTable
            .CommandText = "select 品类,货号,条码,商品名称,品牌,售价,成本,库存,单位,库位 from [原始数据$a2:z100]"
            .ListObject.DisplayName = "表_1"
            .Refresh BackgroundQuery:=False
        End With
        
    ActiveSheet.ListObjects("表_1").Unlist
    Rows(aa).Delete
Application.ScreenUpdating = True
Range("a1").Select

End Sub

青玉1989

你这个需求也太简单了。用VBA实现的话，就是把源数据装进一个数组里，然后取出源数组里特定的几列生成一个新数组，再把这个新数组填入需求表里。如果不需要用代码去匹配需要的列数（直接填入需要匹配的列数），十几行代码就能搞定。而且我看你已经把数据区域转换成了超级表（Table）。其实用PowerQuery不是更简单吗？完成工作没必要舍易求难，但如果是要学习VBA的话，那当我没说。下面是我的代码：
Sub Query()

Dim SourceArr(), ResultArr()
Dim sRows%, tColm%
'    On Error Resume Next
    SourceArr = Sheets("原始数据").ListObjects("productTable").DataBodyRange.Value '这里有个坑，因为数据源是一张超级表所以不能用普通的.CurrentRegion取得数据。
    sRows = UBound(SourceArr, 1) '求原始数据的行数,注意这个行数是不包括标题的。
    ReDim ResultArr(1 To sRows, 1 To 10)
        For i = 2 To sRows
            For j = 1 To 10
                tColm = Application.Match(Sheets("需求").Cells(1, j).Value, Sheets("原始数据").Rows("1:1"), 0) '这句是求得需求表的每一列在原始数据表中对应列的位置
                ResultArr(i, j) = SourceArr(i, tColm)
            Next j
        Next i
            Sheets("需求").[A2].Resize(UBound(ResultArr, 1), UBound(ResultArr, 2)) = ResultArr
End Sub
以上代码亲测有效。可以在sheet2中运行，也可以在模拟中运行。最后说一下，你这个表格有个坑，就是数据区域是一张超级表，所以不能直接用sheets("原始数据").[A1].CurrentRegion来获取数据，必须把超级表转换成区域或者用我代码里的listObject对象（超级表对象）获取数据。