Question

我正在尝试让VBA打开一个选定的工作簿，并根据标题“RGRD”复制数据列。选择带有运行时错误424的EntireColumn后代码失败。我宁愿向下复制，直到列中的最后一个非空单元格。

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

Answer 1

问题出在这一行：

Set rngTest1 = rngSourceRange.EntireColumn.Select

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

rngSourceRange.EntireColumn.Select - 这会选择列
Set rngTest1 = ... - 这会尝试设置范围对象

要修复代码，只需删除.Select

即可

在下面的代码中，我使用更多描述性变量名称，取消了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

Answer 2

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

这使您的数据成为一个不断增长的ActiveSheet.Listobject，它可以在VBA中使用all kinds of features，包括预先计算的行数。

尝试将基于标题的列从一个工作簿复制到另一个工作簿

2 个答案: