Compile into master sheet - vba

Question

I got the following macro that does calculation of percentage of rows filled per column and loops through a directory, and doesnt save the results in the files. Now how can I take these results with a file name and column name and paste it into a master worksheet within my active blank workbook?
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
EDIT
Hi, thank you so much for the reply. I have altered my code slightly(not reflecting your changes). Can you alter this code to take the results of each worksheet and workbook and put into master worksheet? I've had troubles with your code probably because mine altered from the original question.
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

If you do all the calculations in vba you dont have to write anything to the individual sheets:
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