Question

我尝试使用 VBA 宏来遍历文件夹中的所有.xlsx个文件，并将每个文件夹中的相同范围/工作表中的值复制到包含该文件夹的文件中宏。

如何更改每个循环的ThisWorkbook范围？

ThisWorkbook.Worksheets(1).Range("I4:AV83").Value = wb.Worksheets(3).Range("A4:AN83").Value

循环播放的打开文件的范围始终为A4:AN83。范围I4:AV83是第一个文件要复制到的范围，第二个将是I84:AV163，第三个 I164:AV243，等等。

其余代码如下，并改编自www.TheSpreadsheetGuru.com

*original code*

编辑：感谢那些回复的人。由于代码相当长，我已将其删除并在下方发布了更新版本。

我添加了.Range(Cells(9, y1), Cells(48, y2))，现在我遇到了一个问题，它只会从一个已加载的工作表中更新错误范围内的值。

第一张图表的值应显示在I4:AV83范围内，但只有部分最后一张图表的值显示在I9:AV48范围内。

Private Sub CommandButton1_Click()

Dim wb As Workbook
Dim myPath As String
Dim myFile As String
Dim myExtension As String
Dim FldrPicker As FileDialog
Dim y1 As Integer
Dim y2 As Integer

'Set y1 and y2 for value range
  y1 = 4
  y2 = 83

'Optimizes 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

'If folder is not selected
NextCode:
  myPath = myPath
  If myPath = "" Then GoTo ResetSettings

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

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

'Loop through each Excel file in folder
  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

    'Sets values to the looped file's
      ThisWorkbook.Worksheets(1).Range(Cells(9, y1), Cells(48, y2)).Value = wb.Worksheets(3).Range("A4:AN83").Value

    'Closes opened Workbook
      wb.Close

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

    'Update range for next loop
      y1 = y1 + 80
      y2 = y2 + 80

    'Get next file name
      myFile = Dir

  Loop

'Message Box when tasks are completed
  MsgBox "Complete"

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


End Sub

Answer 1

如果将wb.Worksheets(3).Range("A4:AN83").Value替换为wb.Worksheets(3).Range(Cells(x, y), Cells(x2, y2)).Value，则可以轻松地在每个循环上递增x，y，x2和y2。

VBA：每个循环改变范围

1 个答案: