Sub ConsolidateSheetsToPDF()
Dim n, LR1, LR2, LastF As Long
Dim FName As String
Set wb = ThisWorkbook
LastF = InputBox("Enter the last number for the f-values, ie, for 'f10' you enter 10")
Application.ScreenUpdating = False
For f = 1 To LastF 'Uncomment to run pdfs rapid fire
Range("B1").Value = "f" & f
wb.Sheets("Sheet1").Range("A2:J50").ClearContents
wb.Sheets("Sheet2").UsedRange.ClearContents
wb.Sheets("Sheet3").UsedRange.ClearContents
wb.Sheets("Sheet4").UsedRange.ClearContents
n = 1
xDirect$ = ThisWorkbook.Path & "\"
xFname$ = Dir(xDirect$)
Do While xFname$ <> ""
If xFname$ = "Master.xlsm" Then GoTo Passem 'Skip the Workbook you are copying data to, ie. "Master.xlsm"
If xFname$ = wb.Sheets("Sheet1").Range("B1").Value & ".docx" Then
Call WordFileInsert
n = n + 1
GoTo Passem
End If
If xFname$ = wb.Sheets("Sheet1").Range("B1").Value & "1.xlsx" Or xFname$ = wb.Sheets("Sheet1").Range("B1").Value & "2.xlsx" Or xFname$ = wb.Sheets("Sheet1").Range("B1").Value & "3.xlsx" Then
Workbooks.Open (xDirect$ & xFname$), UpdateLinks:=False
Application.Workbooks(xFname$).Activate
Set srcwb = Workbooks(xFname$)
LR1 = srcwb.Sheets(1).Cells(Rows.Count, 1).End(xlUp).Row
wb.Sheets(n).Range("A1").Value = xFname$ 'Filename of copied xlsx file
wb.Sheets(n).Range("A2").Value = "Sheetname: " & srcwb.ActiveSheet.Name
srcwb.Sheets(1).Range("A1:I" & LR1).Copy Destination:=wb.Sheets(n).Range("A3")
Application.CutCopyMode = False 'Clear Clipboard
srcwb.Close savechanges:=False
n = n + 1 'Advance the count to the next sheet number
End If
Passem:
xFname$ = Dir
Loop
wb.Sheets(Array("Sheet1", "Sheet2", "Sheet3", "Sheet4")).Select 'if not all sheets...OR
'Sheets.Select 'for all sheets in the workbook
FName = xDirect$ & wb.Sheets("Sheet1").Range("B1").Value & ".pdf" 'PDF Filename
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=FName, Quality:=xlQualityStandard, _
IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
Sheets(1).Select
Next f
Application.ScreenUpdating = True
End Sub
Sub WordFileInsert()
'This macro will pastespecial the Word document (docx file) that is copied to the clipboard
Dim wdApp As Object
Dim wdDoc As Object
Dim FName As String
Set wb = ThisWorkbook
FName = wb.Sheets("Sheet1").Range("B1").Value
Application.ScreenUpdating = False
'open the word document
Set wdApp = CreateObject("Word.Application")
Set wdDoc = wdApp.Documents.Open(ThisWorkbook.Path & "\" & FName & ".docx")
wdDoc.Range.Select 'select everything in the word document
wdDoc.Range.Copy
wdApp.Visible = True 'show the word document
'Go back to Excel
wb.Sheets("Sheet1").Range("A2").Select
ActiveSheet.PasteSpecial Format:="Text", Link:=False, DisplayAsIcon:=False
'Make the background grid all white
Range("A2:I44").Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorDark1
.TintAndShade = 0
.PatternTintAndShade = 0
End With
wdApp.Quit 'Close Word
Application.ScreenUpdating = True
Range("B1").Select
End Sub