Question

我正在尝试开发一个宏，它将打开由用户提示的位置指定的excel文件，找到特定的列并将整个列粘贴到活动工作簿中。到目前为止，我已经编写了代码，可以遍历目录中的文件，打开文件，搜索列并将整个列存储在数组中。现在每当我尝试运行时错误说＆＃34;溢出＆＃34;！任何人都可以帮我解决这个问题吗？另外，我想在宏中集成以下项目： 1.从每个文件中查找多个列，并将这些列粘贴到工作表中。因此，对于多个文件，我应该动态地将列粘贴到单个工作表中。我怎样才能做到这一点？任何帮助表示赞赏。谢谢。下面是我到目前为止编写的代码：

Sub Test_Template()

'PURPOSE: To loop through all Excel files in a user specified folder and perform a set task on them

Dim wb As Workbook
Dim myPath As String, myFile As String
Dim myExtension As String
Dim t As Range, rng As Range, rng2 As Range
Dim dblAvg As Single, eng_spd As Single, i As Integer
Dim FldrPicker As FileDialog
Dim rowCtr As Integer
Dim myarray1 As Variant
rowCtr = 2


'Optimize Macro Speed
  Application.ScreenUpdating = False
  Application.EnableEvents = False
  Application.Calculation = xlCalculationManual

'Retrieve Target Folder Path From User
  Set FldrPicker = Application.FileDialog(msoFileDialogFolderPicker)

    With FldrPicker
      .Title = "Select A Target Folder"
      .AllowMultiSelect = False
        If .Show <> -1 Then GoTo NextCode
        myPath = .SelectedItems(1) & "\"
    End With


'In Case of Cancel
NextCode:
  myPath = myPath
  If myPath = "" Then GoTo ResetSettings

'Target File Extension (must include wildcard "*")
  myExtension = "*.xls*"

'Target Path with Ending Extention
  myFile = Dir(myPath & myExtension)

'Loop through each Excel file in folder
Execute:
Do While myFile <> ""
    'Set variable equal to opened workbook
      Set wb = Workbooks.Open(Filename:=myPath & myFile)

    'Ensure Workbook has opened before moving on to next line of code
      DoEvents

 'Find "Time" in Row 1
  With wb.Worksheets(1).Rows(9)
   Set t = .Find("Time", lookat:=xlPart)
'If found, copy the column to Sheet 2, Column A
'If not found, present a message
     If Not t Is Nothing Then
        'Columns(t.Column).EntireColumn.Copy _
         ' Destination:=Sheets(3).Range("A1")
    Set rng2 = Columns(t.Column)
    myarray1 = rng2
       Else: MsgBox "Time Not Found"
     End If
  End With

 'Save and Close Workbook
      wb.Close 'SaveChanges:=True

    'Ensure Workbook has closed before moving on to next line of code
      DoEvents

With ActiveSheet
For i = LBound(myarray1) To UBound(myarray1)
    Debug.Print myarray1(i, 1)
Next
End With
    'Get next file name
      myFile = Dir
Loop

'Message Box when tasks are completed
  'MsgBox "Task Complete!"

ResetSettings:
  'Reset Macro Optimization Settings
    Application.EnableEvents = True
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True


End Sub

Answer 1

这里是你的代码与clutter，如goto命令，以及未使用的命令已删除

Sub Test_Template()

    'PURPOSE: To loop through all Excel files in a user specified folder and perform a set task on them

    Dim wb As Workbook
    Dim myPath As String, myFile As String
    Dim myExtension As String
    Dim t As Range, rng As Range, rng2 As Range
    Dim dblAvg As Single, eng_spd As Single, i As Long
    Dim FldrPicker As FileDialog
    Dim rowCtr As Long
    Dim myarray1 As Variant
    rowCtr = 2


    ' Optimize Macro Speed
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.Calculation = xlCalculationManual

    ' Retrieve Target Folder Path From User
    Set FldrPicker = Application.FileDialog(msoFileDialogFolderPicker)

    With FldrPicker
        .Title = "Select A Target Folder"
        .AllowMultiSelect = False
        If .Show = True Then
            myPath = .SelectedItems(1) & "\"
        End If
    End With


    myPath = myPath                                               ' In Case of Cancel
    If myPath <> "" Then

        myExtension = "*.xls*"                                    ' Target File Extension (must include wildcard "*")

        myFile = Dir(myPath & myExtension)                        ' Target Path with Ending Extention

        Do While myFile <> ""                                     ' Loop through each Excel file in folder

            Set wb = Workbooks.Open(Filename:=myPath & myFile)    ' Set variable equal to opened workbook

            DoEvents                                              ' yield processing time to other events

            Set t = wb.Worksheets(1).Rows(9).Find("Time", lookat:=xlPart)  ' Find "Time" in Row 1  ????

            If Not t Is Nothing Then

'               Columns(t.Column).EntireColumn.Copy _
                Destination:=Sheets(3).Range("A1")

                myarray1 = Columns(t.Column)                      ' found: copy the column to Sheet 2, Column A

            Else
                MsgBox "Time Not Found"
            End If

            wb.Close ' SaveChanges:=True                          ' Save and Close Workbook

            DoEvents                                              ' yield processing time to other events

            For i = LBound(myarray1) To UBound(myarray1)
                Debug.Print myarray1(i, 1)
            Next

            myFile = Dir                                          ' Get next file name
        Loop

'       MsgBox "Task Complete!"

    End If

    'Reset Macro Optimization Settings
    Application.EnableEvents = True
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True

End Sub

将整个列复制到excel vba中的数组中

1 个答案: