Monsieur Roo
New Member
- Joined
- Jul 31, 2023
- Messages
- 1
- Office Version
- 365
- Platform
- Windows
In order to not fall foul of the XY problem I'll describe what I am trying to do rather than bore you with the many ill fated attempts trying to get this to work.
The code below opens a worksheet, copy's out some important information, then pastes it into excel file containing the VBA code, where it is formatted and some descriptions are added. This is then copied to word (so it can be saved as a PDF with a password) I know it's rather convoluted but it works well for what I need it for. But I can only do one file at a time.
What I would like to do is select the folder that contains the "important information" worksheets and loop through each one and perform the code below starting from: Dim LastRow As Integer
I am getting into a mess with referencing the correct workbook, wondering if any one can point me in the right direction and save me from the drudgery of this manual repetitive task.
The code below opens a worksheet, copy's out some important information, then pastes it into excel file containing the VBA code, where it is formatted and some descriptions are added. This is then copied to word (so it can be saved as a PDF with a password) I know it's rather convoluted but it works well for what I need it for. But I can only do one file at a time.
What I would like to do is select the folder that contains the "important information" worksheets and loop through each one and perform the code below starting from: Dim LastRow As Integer
I am getting into a mess with referencing the correct workbook, wondering if any one can point me in the right direction and save me from the drudgery of this manual repetitive task.
VBA Code:
Sub import_data_from_RC_FULL()
On Error GoTo ErrorHandler:
Dim FileToOpen As Variant
Dim OpenBook As Workbook
Application.ScreenUpdating = False
FileToOpen = Application.GetOpenFilename(Title:="Browse for your File & Import Range", fileFilter:="Excel Files (*.xls*),*xls*")
If FileToOpen <> False Then
Set OpenBook = Application.Workbooks.Open(FileToOpen)
Dim LastRow As Integer
LastRow = OpenBook.Sheets("NIMS All").Range("A5").End(xlDown).Row
OpenBook.Sheets("NIMS All").Range("A5:F" & LastRow).Copy
ThisWorkbook.Worksheets("RateCard").Range("A5").PasteSpecial xlPasteValues
Application.DisplayAlerts = False
OpenBook.Close False
Range("A5").Copy
Range("J2").PasteSpecial Paste:=xlPasteValues
Sheets("setup").Select
If Range("D3") = "No Valid Contract Number in 'RateCard' Tab" Then MsgBox "No Ratecard data, Please add and return to Step 2": Exit Sub
Call clearall
pos = 1: conno = Range("setup!c6"): ypos = 3
Do While Range("t2000!b" & pos) > 0
If Trim(Len(Range("t2000!b" & pos))) > 0 Then
If conno = Range("t2000!b" & pos) Then
Cells(7, ypos) = Range("t2000!a" & pos)
Cells(8, ypos) = Range("t2000!c" & pos)
ypos = ypos + 1
End If
pos = pos + 1
End If
Loop
Range("C7:J8").Select
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
End With
Selection.Borders(xlEdgeLeft).LineStyle = xlContinuous
Selection.Borders(xlEdgeRight).LineStyle = xlContinuous
Selection.Borders(xlEdgeTop).LineStyle = xlContinuous
Selection.Borders(xlEdgeBottom).LineStyle = xlContinuous
Selection.Borders(xlInsideVertical).LineStyle = xlContinuous
Selection.Borders(xlInsideHorizontal).LineStyle = xlContinuous
If Range("D3") = "No Valid Contract Number in 'RateCard' Tab" Then MsgBox "No Ratecard data, Please add and return to Step 2": Exit Sub
If Len(Trim(Range("c12"))) = 0 Then MsgBox "Please goto step 3 and add 'Contract Live Date' then goto step 4": Exit Sub
Sheets("setup").Select
pos = 5: ypos = 3: pdfpos = 34:
Do While Len(Trim(Range("ratecard!b" & pos))) > 0
cont = Cells(7, ypos)
Range("pdf!a30:w30").Copy
Range("pdf!a" & pdfpos).PasteSpecial
Range("pdf!D" & pdfpos) = cont
Range("pdf!k" & pdfpos) = Cells(8, ypos)
pdfpos = pdfpos + 2
fpos = pdfpos
Do While Range("ratecard!a" & pos) = cont
Range("pdf!a" & pdfpos & ":b" & pdfpos).Merge
Range("pdf!d" & pdfpos & ":l" & pdfpos).Merge
Range("pdf!n" & pdfpos & ":q" & pdfpos).Merge
Range("pdf!r" & pdfpos & ":s" & pdfpos).Merge
Range("pdf!t" & pdfpos & ":u" & pdfpos).Merge
Range("pdf!v" & pdfpos & ":w" & pdfpos).Merge
Range("pdf!a" & pdfpos) = Range("ratecard!b" & pos)
Range("pdf!r" & pdfpos) = Range("ratecard!d" & pos)
Range("pdf!t" & pdfpos) = Range("ratecard!e" & pos)
Range("pdf!v" & pdfpos) = Range("ratecard!f" & pos)
Range("pdf!d" & pdfpos) = "=vlookup(A" & pdfpos & ",'Current Descriptions'!A:C,2,false)"
Range("pdf!n" & pdfpos) = "=vlookup(A" & pdfpos & ",'Current Descriptions'!A:C,3,false)"
pdfpos = pdfpos + 1
pos = pos + 1
Loop
Sheets("pdf").Select
Range("R" & fpos & ":W" & pdfpos).Select
Rows(fpos & ":" & pdfpos).RowHeight = 30
ActiveSheet.Rows("34").RowHeight = 30
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = True
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
End With
Sheets("pdf").Select
Range("A" & fpos & ":Q" & pdfpos).Select
Rows(fpos & ":" & pdfpos).RowHeight = 30
With Selection
.HorizontalAlignment = xlLeft
.VerticalAlignment = xlCenter
.WrapText = True
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
End With
Rows(pdfpos).Activate
ActiveWindow.SelectedSheets.HPageBreaks.Add before:=ActiveCell
Sheets("setup").Select
ypos = ypos + 1
Loop
Application.ScreenUpdating = False
Call CloseWordDocuments
Dim Obj
Set Obj = CreateObject("Word.Application")
Dim pdftemplate As String
pdftemplate = ActiveWorkbook.Sheets("Setup").Range("c23").Value
Set NewObj = Obj.documents.Add(Template:=pdftemplate, NewTemplate:=False, DocumentType:=0)
Sheets("PDF").Select
ActiveSheet.UsedRange.Copy
NewObj.Range.Paste
Application.CutCopyMode = False
Sheets("Setup").Select
Dim myfilename As String
myfilename = ActiveWorkbook.Sheets("Setup").Range("c22").Value
NewObj.Saveas Filename:=myfilename
Sheets("Setup").Select
Range("C13").Copy
Obj.Visible = True
Obj.Activate
Application.ActivateMicrosoftApp xlMicrosoftWord
Obj.Visible = True
Obj.Activate
Obj.Run "TemplateProject.NewMacros.save"
Call clearrateonRCpage
Sheets("RateCard").Select
End If
Exit Sub
ErrorHandler:
MsgBox "An error occured " & vbNewLine & vbNewLine & Err.Number & ": " & Err.Description
Application.DisplayAlerts = True
End Sub