Vba 尝试根据标题将列从一个工作簿复制到另一个工作簿_Vba_Excel

Vba 尝试根据标题将列从一个工作簿复制到另一个工作簿

vba excel

Vba 尝试根据标题将列从一个工作簿复制到另一个工作簿,vba,excel,Vba,Excel,我正试图让VBA打开所选工作簿，并根据标题“RGRD”复制数据列。选择EntireClumn后代码失败，运行时错误为424。我宁愿复制到列中最后一个非空单元格 Sub test() Dim wkbCrntWorkBook As Workbook Dim wkbSourceBook As Workbook Dim rngSourceRange As Range Dim rngDestination As Range Dim rngTest1 As Range Dim strFindThis

我正试图让VBA打开所选工作簿，并根据标题“RGRD”复制数据列。选择EntireClumn后代码失败，运行时错误为424。我宁愿复制到列中最后一个非空单元格

Sub test()

Dim wkbCrntWorkBook As Workbook
Dim wkbSourceBook As Workbook

Dim rngSourceRange As Range
Dim rngDestination As Range
Dim rngTest1 As Range

Dim strFindThis As String

Set wkbCrntWorkBook = ActiveWorkbook

'Opens prompt to select Source file
With Application.fileDialog(msoFileDialogOpen)
.Filters.Clear
.Filters.Add "Excel 2007", "*.xlsx; *.xlsm; *.xlsa", 1
.Filters.Add "Excel 2002-03", "*.xls", 2
.AllowMultiSelect = False
.Show

If .SelectedItems.Count > 0 Then
    Workbooks.Open .SelectedItems(1)

    Set wkbSourceBook = ActiveWorkbook

    'Code searches for key word
    strFindThis = "RGRD"
    Set rngSourceRange = Application.Range("A1:BZ1").Find(What:=strFindThis, Lookat:=xlPart, MatchCase:=False)

    'Selects entire column based on key word header
    Set rngTest1 = rngSourceRange.EntireColumn.Select

    'Swicthes to UMD Price Out Worksbook
    wkbCrntWorkBook.Activate

    'Copies column data from Source to Cell B1 on UMD Price Out Workbook
    Set rngDestination = ActiveSheet.Cells(1, 2)
    rngTest1.Copy rngDestination

    'Formats column to AutFit and Closes Source Worksbook
    rngDestination.CurrentRegion.EntireColumn.AutoFit
    wkbSourceBook.Close False

End If
End With
End Sub

如果您运行的是Excel 2010或更高版本，请尝试使用“插入”>“表格”将数据格式化为表格

这将使您的数据成为一个不断增长的ActiveSheet.Listobject，它在VBA中具有您可以使用的功能，包括预先计算的行数。

问题在这一行：

Set rngTest1 = rngSourceRange.EntireColumn.Select

一条语句只能执行一个操作，但此行执行2，生成错误：

```
rngSourceRange.entireclumn.Select
```
-这将选择列
```
Set rngTest1=…
```
-这将尝试设置范围对象

要修复代码，只需删除

。选择
在下面的代码中，我使用了更具描述性的变量名，消除了Select和Activate操作，并检查是否找到了字符串（列）

Option Explicit

Public Sub CopyRGRD()
    Const FIND_STR = "RGRD"

    Dim destWb As Workbook, srcWb As Workbook, srcUR As Range, destCell As Range
    Dim foundCell As Range, foundCol As Range

    Set destWb = Application.ThisWorkbook   'File where the code executes

    With Application.FileDialog(msoFileDialogOpen)
        .Filters.Clear
        .Filters.Add "Excel 2007", "*.xlsx; *.xlsm; *.xlsa", 1
        .Filters.Add "Excel 2002-03", "*.xls", 2
        .AllowMultiSelect = False
        .Show
        If .SelectedItems.Count > 0 Then
            Application.ScreenUpdating = False
            Set srcWb = Workbooks.Open(.SelectedItems(1))
            Set srcUR = srcWb.Worksheets(1).UsedRange   'Sheet1 in selected file

            Set foundCell = srcUR.Rows(1).Find(What:=FIND_STR, _
                                               Lookat:=xlPart, MatchCase:=False)

            If Not foundCell Is Nothing Then    'Make sure that column RGRD exists
                Set foundCol = srcUR.Columns(foundCell.Column).EntireColumn
                Set destCell = destWb.ActiveSheet.Cells(1, 2)
                foundCol.Copy destCell
                destCell.EntireColumn.AutoFit
            End If
            srcWb.Close False
            Application.ScreenUpdating = True
        End If
    End With
End Sub