时间戳

首页 > 解决方案 > VBA：文本识别 - 将特定列从 sheet1 复制到 sheet2

excel - VBA：文本识别 - 将特定列从 sheet1 复制到 sheet2

问题描述

一个善良的灵魂为我提出的另一个问题制作了这个代码。但我正在考虑文本识别。所以我在sheet1中有一个数据输入，数据输入中的每一列都有一些标题，我想按特定标题名称排序，复制它们，然后将标题与我的关键字匹配的两行列粘贴到sheet2中. 将数据粘贴到 sheet2 中，应该在前两行可用，就像在我的代码中一样。真的想尽可能地保留大部分代码，然后可能只更改我在特定范围内复制两行的子代码。将不胜感激帮助:)

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

标签： excelvbaexcel-formula

解决方案

您可以在工作表或工作表中的某个范围内执行 SQL 语句。这将允许您轻松地仅选择特定列，并按特定列排序。

添加对Microsoft ActiveX 数据对象的引用（工具->引用...）；选择最新版本（通常是 6.1）。

然后您可以编写类似于以下的代码：

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

请注意，没有什么可以阻止您将字符串数组用作选定列或排序字段；使用该Join函数将字段名称组合成逗号分隔的字符串：

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并且sortnames可以从不同的单元格填充：

Dim sheet As Worksheet
Set sheet = Worksheets("Sheet1")
fieldnames = Array(sheet.Range("A1").Value, sheet.Range("B1").Value))

推荐阅读