Question

不是我的代码完全。我在网络中借助我的更改

目的：遍历用户指定文件夹中的所有Excel文件对它们执行设定任务消息来源：www.TheSpreadsheetGuru.com

    Sub LoopAllExcelFilesInFolder()
    Dim wb As Workbook
    Dim myPath As String
    Dim myFile As String
    Dim myExtension As String
    Dim FldrPicker As FileDialog

 'Optimize Macro Speed
      Application.ScreenUpdating = False
      Application.EnableEvents = False
      Application.Calculation = xlCalculationManual
      Application.DisplayAlerts = False
      Application.EnableEvents = False
 'Retrieve Target Folder Path From User
      myPath = ThisWorkbook.Worksheets(1).Range("B1").Value & "\" & 
     ThisWorkbook.Worksheets(1).Range("B2").Value & "\" & 
     ThisWorkbook.Worksheets(1).Range("B3").Value & "\"


    End Sub

Answer 1

不是我的代码完全。我在网络中借助我的更改

目的：遍历用户指定文件夹中的所有Excel文件对它们执行设定任务消息来源：www.TheSpreadsheetGuru.com

    Sub LoopAllExcelFilesInFolder()
    Dim wb As Workbook
    Dim myPath As String
    Dim myFile As String
    Dim myExtension As String
    Dim FldrPicker As FileDialog

 'Optimize Macro Speed
      Application.ScreenUpdating = False
      Application.EnableEvents = False
      Application.Calculation = xlCalculationManual
      Application.DisplayAlerts = False
      Application.EnableEvents = False
 'Retrieve Target Folder Path From User
      myPath = ThisWorkbook.Worksheets(1).Range("B1").Value & "\" & 
     ThisWorkbook.Worksheets(1).Range("B2").Value & "\" & 
     ThisWorkbook.Worksheets(1).Range("B3").Value & "\"

 '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
      Do While myFile <> ""
        'Set variable equal to opened workbook
          Set wb = Workbooks.Open(Filename:=myPath & myFile)
          WS_Count = wb.Worksheets.Count

             ' Begin the loop.

        'Ensure Workbook has opened before moving on to next line of code
          DoEvents
            For I = 1 To WS_Count
        'Change First Worksheet's Background Fill Blue
        'following snippet arranges data in the 4th row and colors it
           With wb.Worksheets(I)
            If (Range("A1") <> "") Then

        'Find the last used row in a Column: column A in this example
            Dim LastRow As Long
            LastRow = Cells(Rows.Count, "A").End(xlUp).Row
            Dim LastCol As Integer
            LastCol = Cells(1, Columns.Count).End(xlToLeft).Column
            LastColcell = Cells(1, LastCol).Address
            Range("A1:" & LastColcell).Font.Color = vbWhite
            Range("A1:" & LastColcell).Interior.Color = RGB(51, 98, 174)
            Rows("1:3").Insert Shift:=xlDown
          Range("G1").FormulaR1C1 = "=SUBTOTAL(9,R[5]C:R[" & LastRow & "]C)"
            Range("G1").AutoFill Destination:=Range("G1:" & LastColcell)
            Range("G1:" & LastColcell).Interior.Color = RGB(255, 255, 0)
            AutoFilterMode = False

            End If
          End With
          Next I
      'Save and Close Workbook
           Dt = Format(Date, "yyyymmdd")

          wb.Close SaveChanges:=True

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

        '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

通过将表数据偏移几行，使用多个选项卡格式化6个Excel工作表的VBA代码

1 个答案: