编译成主表

Question

我得到了以下宏，它计算每列填充的行百分比并循环遍历目录，并且不会将结果保存在文件中。现在，如何将这些结果与文件名和列名一起使用，并将其粘贴到我的活动空白工作簿中的主工作表中？

Sub Calculation()

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

Dim wb As Workbook, fileNames As Object, errCheck As Boolean 'part of loop


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




 'get user input for files to search
Set fileNames = CreateObject("Scripting.Dictionary")
errCheck = UserInput.FileDialogDictionary(fileNames)
If errCheck Then
   Exit Sub
End If
'''
For Each Key In fileNames 'loop through the dictionary I added the below Sept 9, 2015
    Set wb = Workbooks.Open(fileNames(Key)) 'I added the below Sept 9, 2015
    wb.Application.Visible = False 'make it not visible I added the below Sept 9, 2015




    Dim xrng As Range, lrw As Long, lrng As Range, i As Long
    Dim LstCo As Long, ws As Worksheet


    With Application
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
    End With

    For Each ws In ActiveWorkbook.Worksheets
        With ws

            If Not Application.WorksheetFunction.CountA(.Cells) = 0 Then

                LstCo = .Cells.Find("*", , xlValues, xlWhole, xlByColumns, xlPrevious, False).Column
                For i = 1 To LstCo
                    With .Columns(i)
                        .TextToColumns Destination:=.Cells(1, 1), DataType:=xlDelimited, TrailingMinusNumbers:=True
                    End With
                Next

                lrw = .Columns("A:Y").Find("*", , xlValues, , xlRows, xlPrevious).Row
                If lrw = 1 Then lrw = 2
                Set lrng = .Range("A" & lrw + 2)

                With .Range("A2:A" & lrw)
                    lrng.Formula = "=COUNTA(" & .Address(0, 0) & ")/ROWS(" & .Address(0, 0) & ")"
                End With


                Set xrng = .Range(lrng, .Cells(lrng.Row, LstCo))


                lrng.AutoFill xrng, Type:=xlFillDefault
                xrng.Style = "Percent"
            End If
        End With
    Next













 wb.Application.Visible = True '' I added this Sept 9, 2015
 wb.Close savechanges:=False 'close the workbook do not save
Set wb = Nothing 'release the object

Next 'End of the fileNames loop
Set fileNames = Nothing





'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

修改

嗨，非常感谢你的回复。我稍微修改了我的代码（没有反映你的更改）。您可以更改此代码以获取每个工作表和工作簿的结果并放入主工作表吗？我的代码遇到了麻烦，可能是因为我的原始问题改变了。

Sub Calculation2()


Dim wb As Workbook, fileNames As Object, errCheck As Boolean
    Dim ws As Worksheet, wks As Worksheet, wksSummary As Worksheet
    Dim boolWritten As Boolean
    Dim xrng As Range, lrw As Long, lrng As Range, i As Long
    Dim LstCo As Long

   'Skipped worksheet for file names
   Dim wksSkipped As Worksheet
   Set wksSkipped = ThisWorkbook.Worksheets("Skipped")


     ' Turn off screen updating and automatic calculation
    With Application
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
    End With





'get user input for files to search
Set fileNames = CreateObject("Scripting.Dictionary")
errCheck = UserInput.FileDialogDictionary(fileNames)
If errCheck Then
   Exit Sub
End If
'''
For Each Key In fileNames 'loop through the dictionary




On Error Resume Next
Set wb = Workbooks.Open(fileNames(Key))
If Err.Number <> 0 Then
    Set wb = Nothing    ' or set a boolean error flag
End If
On Error GoTo 0    ' or your custom error handler

'putting skipped files into skipped sheet
If wb Is Nothing Then
wksSkipped.Cells(wksSkipped.Cells(wksSkipped.Rows.Count, "A").End(xlUp).Row + 1, 1) = fileNames(Key)

Else
    Debug.Print "Successfully loaded " & fileNames(Key)
    wb.Application.Visible = False 'make it not visible
    ' more working with wb




 ' Check each sheet in turn
    For Each ws In ActiveWorkbook.Worksheets
        With ws



           'adding calculation code





    With Application
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
    End With



            If Not Application.WorksheetFunction.CountA(.Cells) = 0 Then

                LstCo = .Cells.Find("*", , xlValues, xlWhole, xlByColumns, xlPrevious, False).Column
                For i = 1 To LstCo
                    With .Columns(i)
                        .TextToColumns Destination:=.Cells(1, 1), DataType:=xlDelimited, TrailingMinusNumbers:=True
                    End With
                Next

                lrw = .Columns("A:Y").Find("*", , xlValues, , xlRows, xlPrevious).Row
                If lrw = 1 Then lrw = 2
                Set lrng = .Range("A" & lrw + 2)

                With .Range("A2:A" & lrw)
                    lrng.Formula = "=COUNTA(" & .Address(0, 0) & ")/ROWS(" & .Address(0, 0) & ")"
                End With


                Set xrng = .Range(lrng, .Cells(lrng.Row, LstCo))


                lrng.AutoFill xrng, Type:=xlFillDefault
                xrng.Style = "Percent"
            End If















    With Application
        .ScreenUpdating = True
        .Calculation = xlCalculationAutomatic
        Application.CalculateFull
    End With








        End With
    Next ws
wb.Close savechanges:=True 'close the workbook do not save
Set wb = Nothing 'release the object
End If

Next 'End of the fileNames loop
Set fileNames = Nothing


' Reset system settings
With Application
   .Calculation = xlCalculationAutomatic
   .ScreenUpdating = True
   .Visible = True
End With
End Sub

Answer 1

如果您在vba中进行所有计算，则无需在单张纸上写任何内容：

Sub calculations()
Dim wb As Workbook, fileNames As Object, errCheck As Boolean 'part of loop


Dim ws As Worksheet
Dim resultSheet As Worksheet
Dim i As Long
Dim lco As Integer
Dim lrw As Integer
Dim resultRow As Integer
Dim measurement As Double

Set resultSheet = Application.ActiveSheet
resultRow = 1

'Optimize Macro Speed
  Application.ScreenUpdating = False
  Application.EnableEvents = False
  Application.Calculation = xlCalculationManual
'get user input for files to search
  Set fileNames = CreateObject("Scripting.Dictionary")
  errCheck = UserInput.FileDialogDictionary(fileNames)
  If errCheck Then Exit Sub


For Each Key In fileNames 'loop through the dictionary I added the below Sept 9, 2015
    Set wb = Workbooks.Open(fileNames(Key)) 'I added the below Sept 9, 2015
    wb.Application.Visible = False 'make it not visible I added the below Sept 9, 2015

    For Each ws In wb.Worksheets
        If Not Application.WorksheetFunction.CountA(ws.Cells) = 0 Then
            'define the range to measure
            lco = ws.Cells.Find("*", , xlValues, xlWhole, xlByColumns, xlPrevious, False).Column
            lrw = ws.Columns("A:Y").Find("*", , xlValues, , xlRows, xlPrevious).Row
            If lrw = 1 Then lrw = 2
            For i = 1 To lco
                measurement = Application.WorksheetFunction.CountA(ws.Range(ws.Cells(1, i), ws.Cells(lrw, i))) / lrw
                resultSheet.Cells(resultRow, 1).Value = wb.name
                resultSheet.Cells(resultRow, 2).Value = ws.Name
                resultSheet.Cells(resultRow, 3).Value = Col_Letter(i)
                resultSheet.Cells(resultRow, 4).Style = "Percent"
                resultSheet.Cells(resultRow, 5).Value = measurement
                resultRow = resultRow + 1
            Next
        End If
    Next
    wb.Application.Visible = True '' I added this Sept 9, 2015
    wb.Close savechanges:=False 'close the workbook do not save
    Set wb = Nothing 'release the object
Next 'End of the fileNames loop

Set fileNames = Nothing
'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

Function Col_Letter(lngCol As Long) As String
    Dim vArr
    vArr = Split(Cells(1, lngCol).Address(True, False), "$")
    Col_Letter = vArr(0)
End Function