I am making a tool in excel VBA to bulk create some kind of invoices to each customer. We are making LIVE streams and selling kids clothing, then we write all our orders to excel sheet. Example:
orders list
Then we have to sort all those orders by customer (there are many of them) and create some kind of invoice for each customer. Example: "invoice template"
I use this code to bulk create those and download as pdfs.
Sub Create_PDF_Files()
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Dim dsh As Worksheet
Dim tsh As Worksheet
Dim setting_Sh As Worksheet
Set dsh = ThisWorkbook.Sheets("uzsakymai")
Set tsh = ThisWorkbook.Sheets("lapukas")
Set setting_Sh = ThisWorkbook.Sheets("Settings")
Application.DisplayStatusBar = True
Application.StatusBar = ""
Dim i As Integer
Dim File_Name As String
For i = 2 To dsh.Range("A" & Application.Rows.Count).End(xlUp).Row
Application.StatusBar = i - 1 & "/" & dsh.Range("A" & Application.Rows.Count).End(xlUp).Row - 1
tsh.Range("D1").Value = dsh.Range("C" & i).Value
tsh.Range("A4").Value = dsh.Range("B" & i).Value
tsh.Range("B4").Value = dsh.Range("A" & i).Value & " - " & dsh.Range("E" & i).Value
tsh.Range("P4").Value = dsh.Range("D" & i).Value
File_Name = dsh.Range("A" & i).Value & "(" & dsh.Range("C" & i).Value & "-" & dsh.Range("D" & i).Value & ").pdf"
tsh.ExportAsFixedFormat xlTypePDF, setting_Sh.Range("F4").Value & "\" & File_Name
Next i
Application.StatusBar = ""
MsgBox "Done"
End Sub
But what it does is creating invoice for each item.
EXAMPLE
Any ideas how could I make it work for me as I want it to work?
---EDIT---
After ALeXceL answer, it seems to have some bugs. I changed my code to his code, and I see some progress in creating this program, but what it does, is it shows first item correctly, but all the other items are appearing starting on A24 cell. EXAMPLE
---EDIT---
IT WORKS!!!
Assuming that "uzsakymai" is "orders", the 'data sheet' (dsh) and "lapukas" is the 'template' sheet (tsh), I did these changes, added some counters, in order to the logic flows the right way:
Important: before put this code to run you MUST classify the 'orders' table (dsh, or "uzsakymai") first by Name, then, by Size (as you wish, according to the images posted)
Option Explicit
Sub Create_PDF_Files()
Dim Orders_sh As Worksheet
Dim Template_sh As Worksheet
Dim setting_Sh As Worksheet
Dim oCell As Excel.Range
Dim strKey_TheName As String
Dim lngTemplate_A As Long
Dim lngSumOfItems As Long
Dim dblSumOfValues As Double
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Set Orders_sh = ThisWorkbook.Sheets("uzsakymai")
Set Template_sh = ThisWorkbook.Sheets("lapukas")
Set setting_Sh = ThisWorkbook.Sheets("Settings")
Application.DisplayStatusBar = True
Application.StatusBar = ""
Dim lngI As Long
Dim File_Name As String
'At this point, the Orders_sh worksheet should already have its fields properly sorted/ordered. (Name, then Size)
lngI = 2
Application.StatusBar = lngI - 1 & "/" & Orders_sh.Range("A11").End(xlUp).Row - 1 'a maximum of 10 items can be written here!
Set oCell = Orders_sh.Range("A" & lngI) ' the initial cell
Do
strKey_TheName = UCase(Orders_sh.Range("C" & lngI).Value)
lngSumOfItems = 0
dblSumOfValues = 0
Do
Template_sh.Range("D1").Value = Orders_sh.Range("C" & lngI).Value
lngTemplate_A = IIf(lngSumOfItems = 0, 4, Template_sh.Range("A10").End(xlUp).Offset(1, 0).Row)
Template_sh.Range("A" & lngTemplate_A).Value = Orders_sh.Range("B" & lngI).Value
Template_sh.Range("B" & lngTemplate_A).Value = Orders_sh.Range("A" & lngI).Value & " - " & Orders_sh.Range("E" & lngI).Value
Template_sh.Range("P" & lngTemplate_A).Value = Orders_sh.Range("D" & lngI).Value
lngSumOfItems = lngSumOfItems + 1
dblSumOfValues = dblSumOfValues + Orders_sh.Range("D" & lngI).Value
File_Name = lngSumOfItems & "(" & Orders_sh.Range("C" & lngI).Value & "-" & VBA.Round(dblSumOfValues, 0) & ").pdf"
lngI = lngI + 1
Set oCell = oCell.Offset(1, 0)
Loop Until strKey_TheName <> UCase(oCell.Offset(0, 2).Value)
Template_sh.ExportAsFixedFormat xlTypePDF, setting_Sh.Range("F4").Value & "\" & File_Name
Template_sh.Range("D1").Value = ""
Template_sh.Range("A4:P10").ClearContents
Loop Until Len(oCell.Value) = 0
Application.StatusBar = ""
MsgBox "Done"
End Sub
Related
I tried to set up a code to have a message alert pop-up when a reagent is expiring in 7 days and when the reagent is expired, when the workbook opens. The message should include the reagent that is expired. I only attempted to have the code work for the 'FA Reagents' (A4:A20) and those reagents expiration dates (C4:C20), but I eventually would like to have the code work for all the reagents in this sheet.
Excel Sheet
Private Sub Workbook_Open()
Dim ws As Worksheet
Dim rReagents As Range
Set rReagents = Range("A4:A20")
Dim rExpiration As Range
Set rExpiration = Range("C4:C20")
Dim lLastrow As Long, i As Long
Set ws = Worksheets("Reagent-Equipment")
lLastrow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
With ws
For i = 2 To lLastrow
If .Cells(i, 2) = Date + 7 Then MsgBox ("Reagent expiring in 7 days for " & .Cells(i, 1))
If .Cells(i, 2) = Date Then MsgBox ("Reagent expiring today for " & .Cells(i, 1))
Next
End With
End Sub
This is the code I tried, but I can't a notification to pop-up when the workbook opens when a reagent is expired, or expired within 7 days.
You may find the following code of interest
Private Sub Workbook_Open()
Dim myShortDate As String
Dim myExpired As String
Dim ws As Worksheet
Set ws = Worksheets("Reagent-Equipment")
Dim myReagents As Variant
myReagents = Application.WorksheetFunction.Transpose(ws.Range("A4:A20").Value)
Dim myExpiry As Variant
myExpiry = Application.WorksheetFunction.Transpose(ws.Range("C4:C20").Value)
Dim myIndex As Long
myIndex = 1
Dim myItem As Variant
For Each myItem In myReagents
If Now > VBA.CDate(myExpiry(myIndex)) Then
If VBA.Len(myExpired) = 0 Then
myExpired = vbTab & myReagents(myIndex)
Else
myExpired = myExpired & vbCrLf & vbTab & myReagents(myIndex)
End If
ElseIf Now + 7 > VBA.CDate(myExpiry(myIndex)) Then
If VBA.Len(myShortDate) = 0 Then
myShortDate = vbTab & myReagents(myIndex) & " on " & myExpiry(myIndex)
Else
myShortDate = myShortDate & vbCrLf & vbTab & myReagents(myIndex) & " on " & myExpiry(myIndex)
End If
End If
myIndex = myIndex + 1
Next
If VBA.Len(myExpired) > 0 Then
myExpired = "Expired Reagents" & vbCrLf & vbCrLf & myExpired & vbCrLf & vbCrLf
End If
If VBA.Len(myShortDate) > 0 Then
myShortDate = "Reagents due to expire " & vbCrLf & vbCrLf & myShortDate & vbCrLf & vbCrLf
End If
Dim myMessage As String
myMessage = myExpired & myShortDate
If VBA.Len(myMessage) > 0 Then
MsgBox myMessage, vbCritical
End If
End Sub
I have written a quite complex VBA script to run on a Word document to
transform it into an email body (together with a bunch of other documents),
combine it with other documents and save as pdf-attachment,
open email-distribution lists
create outlook items and put the distribution lists into a bcc field and body from earlier document
The script worked quite fine until it stopped for unclear to me reason. A "Run-time error '1001': Method 'Range' of object '_Global' failed." started to occur in the "Step 3 ...", specifically in the second line:
objLista.Worksheets(1).Activate
last_row = Range("A1").End(xlDown).Row
The script activates the worksheet just fine, but fails to do anything else with it. I tried to use explicit names of the workbook and worksheet in question, but it didn't help. The same lines in different yet similar script still work well. So I find it hard to find the source of the problem and correct it. I use MS Windows 10, and Office 365.
The whole script below:
Sub script()
' >>>>>>>>>>>>>>>>>>>>>>> Step 0. Declaration of variables and paths <<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
Dim Disclaimer_Path As String
Dim Email_Path As String
Dim objOutlook As Object
Dim objMail As Object
Dim ExcelApp As Excel.Application
Dim objLista As Workbook
Dim Today As String
Today = Format(Date, "yyyymmdd")
Disclaimer_Path = ...
Email_Path = "!_email.docx"
Distribution_list_Path = "!_List.xlsm"
Distribution_list_Path = "!_List_2.xlsm"
Pdf_Path = ...
Set objOutlook = CreateObject("Outlook.Application")
Set ExcelApp = New Excel.Application
' >>>>>>>>>>>>>>>>>>>>>>> Step 1. Creating e-mail body <<<<<<<<<<<<<<<<<<<<<<<<<<<
' First creating an email-body
Documents.Open FileName:=ActiveDocument.Path & "\1_News.docx"
Documents.Open FileName:=ActiveDocument.Path & "\2_Essay.docx"
Documents.Open FileName:=ActiveDocument.Path & "\3_Comment.docx"
Documents.Open FileName:=Disclaimer_Path
Documents.Open FileName:=Email_Path
Documents("1_News.docx").Activate
Selection.WholeStory
Selection.Copy
Documents("!_Email.docx").Activate
With Selection
.MoveDown
.MoveDown
.PasteAndFormat wdPasteDefault
End With
Documents("2_Essay.docx").Activate
Selection.WholeStory
Selection.Copy
Documents("!_Email.docx").Activate
Selection.PasteAndFormat wdPasteDefault
Documents("3_Comment.docx").Activate
Selection.WholeStory
Selection.Copy
Documents("!_Email.docx").Activate
With Selection
.PasteAndFormat wdPasteDefault
.WholeStory
End With
' Cleaning
Documents("2_Essay.docx").Close SaveChanges:=wdDoNotSaveChanges
Documents("3_Comment.docx").Close SaveChanges:=wdDoNotSaveChanges
Documents("Disclaimer.docx").Close SaveChanges:=wdDoNotSaveChanges
Stop
' >>>>>>>>>>>>>>>>>>>>>>>>>>>>> Step 2. Creation of pdf <<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
Documents("1_News.docx").Activate
Selection.WholeStory
Selection.Copy
ThisDocument.Activate
With Selection
'.Range.Text = vbNewLine
.MoveDown
.PasteAndFormat wdPasteDefault
.Range.Text = vbNewLine
.MoveDown
End With
ActiveDocument.ActiveWindow.View.Type = wdMasterView
With ActiveDocument.Subdocuments
.AddFromFile Name:=ActiveDocument.Path & "\2_Essay.docx"
.AddFromFile Name:=ActiveDocument.Path & "\3_Comment.docx"
.AddFromFile Name:=ActiveDocument.Path & "\4_Preview.docx"
.AddFromFile Name:=ActiveDocument.Path & "\5_Comment_2.docx"
.AddFromFile Name:=ActiveDocument.Path & "\8_Calendar.docx"
.AddFromFile Name:=Disclaimer_Path
End With
'Returns to standard view
ActiveDocument.ActiveWindow.View.Type = wdPrintView
Selection.HomeKey Unit:=wdStory
Stop
ActiveDocument.ExportAsFixedFormat Pdf_Path, wdExportFormatPDF
' >>>>>>>>>>>>>>>>>>>>>>>> Step 3. Creating Distribution lists <<<<<<<<<<<<<<<<<<<<<<<<<<<<
Set objLista = ExcelApp.Workbooks.Open(Distribution_list_Path)
ExcelApp.Visible = True
Dim lista_1 As String, lista_2 As String, lista_3 As String, lista_4 As String, lista_5 As String, lista_6 As String, lista_7 As String, lista_8 As String, lista_9 As String
lista_1 = ""
lista_2 = ""
lista_3 = ""
lista_4 = ""
lista_5 = ""
lista_6 = ""
lista_7 = ""
lista_8 = ""
lista_9 = ""
objLista.Worksheets(1).Activate
last_row = Range("A1").End(xlDown).Row
For i = 1 To last_row
lista_1 = lista_1 & "; " & Cells(i, 1).Value
Next i
objLista.Worksheets(2).Activate
last_row = Range("A1").End(xlDown).Row
For i = 1 To last_row
lista_2 = lista_2 & "; " & Cells(i, 1).Value
Next i
objLista.Worksheets(3).Activate
last_row = Range("A1").End(xlDown).Row
For i = 1 To last_row
lista_3 = lista_3 & "; " & Cells(i, 1).Value
Next i
objLista.Worksheets(4).Activate
last_row = Range("A1").End(xlDown).Row
For i = 1 To last_row
lista_4 = lista_4 & "; " & Cells(i, 1).Value
Next i
objLista.Worksheets(5).Activate
last_row = Range("A1").End(xlDown).Row
For i = 1 To last_row
lista_5 = lista_5 & "; " & Cells(i, 1).Value
Next i
objLista.Worksheets(6).Activate
last_row = Range("A1").End(xlDown).Row
For i = 1 To last_row
lista_6 = lista_6 & "; " & Cells(i, 1).Value
Next i
' Now differentr set of lists
Set objLista_2 = ExcelApp.Workbooks.Open(Distribution_list_Path_2)
objLista_2.Worksheets(1).Activate
last_row = Range("A1").End(xlDown).Row
For i = 1 To last_row
lista_7 = lista_7 & "; " & Cells(i, 1).Value
Next i
objLista_2.Worksheets(2).Activate
last_row = Range("A1").End(xlDown).Row
For i = 1 To last_row
lista_8 = lista_8 & "; " & Cells(i, 1).Value
Next i
objLista_2.Worksheets(3).Activate
last_row = Range("A1").End(xlDown).Row
For i = 1 To last_row
lista_9 = lista_9 & "; " & Cells(i, 1).Value
Next i
' >>>>>>>>>>>>>>>>>>>>>>>>>>>>> Step 4. Creates e-mails <<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
Documents("!_Email.docx").Activate
Selection.Copy
For Each Item In Array(lista_1, lista_2, lista_3, lista_4, lista_5, lista_6, lista_7, lista_8, lista_9)
With objOutlook.CreateItem(0)
oAccount = ""
.bcc = Item
.Subject = "Weekly"
.Attachments.add Pdf_Path
Set Editor = .GetInspector.WordEditor
Editor.Content.Paste
.Display
End With
Next Item
'Cleaning
Documents("1_News.docx").Close SaveChanges:=wdDoNotSaveChanges
Documents("!_email.docx").Close SaveChanges:=wdDoNotSaveChanges
Workbooks("!_List.xlsm").Worksheets("List_1").Activate
Range("A1").Select 'To żeby uniknąć jednego z błędów, który się wcześniej wywalał, gdy arkusz był zamykany z kursorem w innym miejscu niż "A1"
Workbooks("!_List.xlsm").Close SaveChanges:=wdDoNotSaveChanges
Workbooks("!_List_2.xlsm").Worksheets(1).Activate
Range("A1").Select 'To żeby uniknąć jednego z błędów, który się wcześniej wywalał, gdy arkusz był zamykany z kursorem w innym miejscu niż "A1"
Workbooks("!_List_2.xlsm").Close SaveChanges:=wdDoNotSaveChanges
End Sub
I know this code is a mess but it's been at least working with no errors for weeks. The directories of all the files in question exist.
'''
Sub NEW_PO()
'''''''''''''''''''''''''''''''''''Declare Variables''''''''''''''''''''''''''''''''''''''''''''
Dim disc As String
Dim New_Data_Column As Long 'last date ordered column (number)
Dim NewPO_num As String 'New_Data_Column - 10 (needs leading "0" for single digits)
Dim Job_Num As String '= C2
Dim Cost_Code As String '= Active sheet name
Dim lastCol As String 'last date ordered column (Letter)
Dim sht As Worksheet
Dim lastRow As Long 'last row of description column
Set sht = ActiveSheet
''''''''''''''''''''''Find last row and column(letter)''''''''''''''''''''''''''''''''''''''''''
New_Data_Column = Cells(8, Columns.count).End(xlToLeft).Column
lastCol = Split(Columns(Range("A8").End(xlToRight).Column).Address(, False), ":")(1)
lastRow = sht.Cells(sht.Rows.count, 3).End(xlUp).Row
'''''''''''''''''''''''''''''Check for Data'''''''''''''''''''''''''''''''''''''''''''''''''''''
If WorksheetFunction.CountA(Range(lastCol & "11:" & lastCol & lastRow)) = 0 Then
MsgBox "Error! Please enter data to continue."
Exit Sub
ElseIf WorksheetFunction.CountA(Range(lastCol & "10")) = 0 Then
MsgBox "Error! Please enter date to continue."
Range(lastCol & "10").Select
Exit Sub
Else
''''''''''''''''''''''''''''''''Propmt for description of PO''''''''''''''''''''''''''''''''''''
disc = InputBox("Please enter a description for this Purchase Order.", "New Purchase Order")
If disc = "" Then
MsgBox "You Must Enter A Description!"
Exit Sub
End If
''''''''''''''''''''''''''''''''''Set Cost Code''''''''''''''''''''''''''''''''''''''''''''''''
Cost_Code = sht.name
'''''''''''''''''''''''''''''''''Set Job Number''''''''''''''''''''''''''''''''''''''''''''''''
Job_Num = sht.Cells(2, 4).Text 'as text to keep formatting
'''''''''''''''''''''''''''''Set New Purchase Order Number'''''''''''''''''''''''''''''''''''''
sht.Range("A4").Value = sht.Range("A4").Value + 1
If sht.Range("A4").Value < 10 Then
NewPO_num = "0" & sht.Range("A4").Value
Else
NewPO_num = sht.Range("A4").Value
End If
''''''''''''Open PO Template and save as PO number & Copy PO to S/R Log''''''''''''''''''''
Dim sPath As String
sPath = Application.ThisWorkbook.path
Dim i As Integer
Dim wkb1 As Workbook
Dim sht1 As Worksheet
Dim wkb2 As Workbook
Dim sht2 As Worksheet
Dim lastPO_row As Long
Dim lastSR_row As Long
Dim wkb3 As Workbook
Dim sht3 As Worksheet
Dim sht4 As Worksheet
Application.ScreenUpdating = False
Set wkb1 = ThisWorkbook
Set wkb2 = Workbooks.Open(sPath & "\1 CONSTRUCTION\Purchase Orders\Purchase Order Template.xlsm")
Set wkb3 = Workbooks.Open(sPath & "\1 CONSTRUCTION\RECEIVED MATERIALS\SR Log.xlsx")
Set sht1 = wkb1.Sheets(Cost_Code)
Set sht2 = wkb2.Sheets("Sheet1")
Set sht3 = wkb3.Sheets("Sheet1")
Set sht4 = wkb2.Sheets("Job Addresses")
'''
This is where the error is occurring. Normally it would save the template as specified with no problems. I have deleted the code and written it in notepad and pasted it back into excel and it still gives an error. I've tried on multiple computers with the same result. I even uninstalled and reinstalled office and still not working.
'''
wkb2.SaveAs (sPath & "\1 CONSTRUCTION\Purchase Orders\" & Cost_Code & "\" & Job_Num & "-" & NewPO_num
& "-" & Cost_Code & " " & disc & ".xlsm")
wkb3.SaveAs (sPath & "\1 CONSTRUCTION\RECEIVED MATERIALS\" & Cost_Code & "\" & Job_Num & "-" &
NewPO_num & "-" & Cost_Code & " " & disc & ".xlsx")
sht2.name = Job_Num & "-" & NewPO_num & "-" & Cost_Code & " " & disc
lastPO_row = sht2.Cells(sht.Rows.count, 3).End(xlUp).Row + 1
lastSR_row = sht3.Cells(sht.Rows.count, 1).End(xlUp).Row + 1
''''''''''''Copy relevant entries to PO sheet and Shipping/Receiving Log'''''''''''''''''''
For i = 11 To lastRow
If sht1.Cells(i, New_Data_Column).Value <> "" Then
sht1.Range(lastCol & i).Copy
sht2.Range("A" & lastPO_row).PasteSpecial xlPasteValues
sht3.Range("D" & lastSR_row).PasteSpecial xlPasteValues
sht1.Range("B" & i & ":C" & i).Copy
sht2.Range("B" & lastPO_row & ":C" & lastPO_row).PasteSpecial xlPasteValues
sht3.Range("A" & lastSR_row & ":B" & lastSR_row).PasteSpecial xlPasteValues
lastPO_row = lastPO_row + 1
lastSR_row = lastSR_row + 1
End If
Next
sht2.Range("E6").Value = wkb1.Sheets("PM Dashboard").Range("O3").Value
sht2.Range("E7").Value = Job_Num & "-" & NewPO_num & "-" & Cost_Code
sht2.Range("E8").Value = Dashboard.Sheets("PM Dashboard").Range("Y2").Value
'add this job's address to list of addresses on PO
sht4.Range("A7").Value = wkb1.Sheets("PM Dashboard").Range("O3").Value & vbNewLine _
& wkb1.Sheets("PM Dashboard").Range("AP3").Value & vbNewLine & wkb1.Sheets("PM
Dashboard").Range("AP4").Value
wkb2.Save
sht3.Range("C1").Value = Job_Num & "-" & NewPO_num & "-" & Cost_Code & " " & disc
wkb3.Save
wkb3.Close
'''''''''''''''''''''copy over last column and hide previous'''''''''''''''''''''
sht1.Columns(New_Data_Column).Copy
sht1.Columns(New_Data_Column + 1).PasteSpecial Paste:=xlPasteFormats
sht1.Range(lastCol & "8:" & lastCol & "9").Copy
sht1.Range(lastCol & "8:" & lastCol & "9").Offset(0, 1).PasteSpecial Paste:=xlPasteValues
Call HIDE
wkb1.Save
Application.ScreenUpdating = True
End If
End Sub
'''
I have used hyperlinks.add several times now and never had any problems with it.
Now I added a line of code: SourceBook.Sheets(ESN & "_SV" & SV).Hyperlinks.Add Anchor:=Range("A" & i), _
Address:=ToPath & NewName to my base code (which you can find under here). This should add a link to the newly created document.
The problem is that excel always says it cannot open the file. The link I enter via code is right, as I copied it with debug.print and it opened the file without a problem.
It came to my attention that the hyperlink I added was modified by excel when I hold my mouse over the hyperlink. I wonder how this is possible.
A second problem I encounterd is that when I enter the hyperlink manually and navigate manually to the file to make sure it takes the right file, excel still modifies my link and says "cannot open specified file".
Anyone an idea what might go wrong here? Thanks!
Code:
`Application.ScreenUpdating = False
Dim i, j, FSO As Object, SV, ESN, PartName, ToPath, FromPath, NewName, MsgBoxAnswer, TargetBook As Workbook, SourceBook As Workbook
Dim OS, PN, SN, ProjectNumber, Customer, StartDate, EndDate, LastRowCMM
ESN = ActiveWorkbook.ActiveSheet.Range("G2").Value
SV = ActiveWorkbook.ActiveSheet.Range("K2").Value
ProjectNumber = ActiveWorkbook.ActiveSheet.Range("A3").Value
Customer = ActiveWorkbook.ActiveSheet.Range("G3").Value
Set FSO = CreateObject("scripting.filesystemobject")
PGB.Min = 0
PGB.Value = 0
PGB.Max = 22
'Create main folder
If SV <> 1 Then
SV = "(SV " & SV & ")"
ToPath = "U:\tmo\vanmolle\fiches constat\Fiches constats #" & ESN & " " & SV
Else
ToPath = "U:\tmo\vanmolle\fiches constat\Fiches constats #" & ESN
End If
If FSO.folderexists(ToPath) = True Then
MsgBoxAnswer = MsgBox("Folder already created.", vbExclamation, "Folder exists.")
Exit Sub
End If
FSO.createfolder (ToPath)
'Create all Excel files & fill them in
For i = 6 To 27
FromPath = "U:\tmo\VANMOLLE\Fiches constat\Template fiches constat LEAP.xlsm"
If SV <> 1 Then
ToPath = "U:\tmo\vanmolle\fiches constat\Fiches constats #" & ESN & " " & SV & "\"
Else
ToPath = "U:\tmo\vanmolle\fiches constat\Fiches constats #" & ESN & "\"
End If
FSO.copyfile Source:=FromPath, Destination:=ToPath
NewName = "#" & ESN & "_" & ActiveWorkbook.ActiveSheet.Range("A" & i) & ".xlsm"
If SV <> 1 Then
FromPath = "U:\tmo\vanmolle\fiches constat\Fiches constats #" & ESN & " " & SV & "\Template fiches constat LEAP.xlsm"
Else
FromPath = "U:\tmo\vanmolle\fiches constat\Fiches constats #" & ESN & "\Template fiches constat LEAP.xlsm"
End If
Name FromPath As ToPath & NewName
Set SourceBook = ThisWorkbook
Set TargetBook = Workbooks.Open(ToPath & NewName)
TargetBook.Sheets("Sheet1").Activate
PartName = SourceBook.ActiveSheet.Range("A" & i).Value
OS = SourceBook.ActiveSheet.Range("D" & i).Value
PN = SourceBook.ActiveSheet.Range("B" & i).Value
SN = SourceBook.ActiveSheet.Range("C" & i).Value
If SN = "" Then SN = "N/A"
StartDate = SourceBook.ActiveSheet.Range("G" & i).Value
EndDate = SourceBook.ActiveSheet.Range("H" & i).Value
'check for right CMM
'LastRowCMM = TargetBook.Sheets("Révision CMM").Range("B6").End(xlDown).Row
'For j = 1 To LastRowCMM
'If PartName = TargetBook.Sheets("Révision CMM").Range("A" & j).Value Then ActiveWorkbook.ActiveSheet.Range("A23").Value = ActiveWorkbook.Sheets("Révision CMM").Range("B" & j).Value
'Next j
TargetBook.ActiveSheet.Range("B9").Value = PartName
TargetBook.ActiveSheet.Range("B10").Value = OS
TargetBook.ActiveSheet.Range("B11").Value = "# " & ESN
TargetBook.ActiveSheet.Range("B12").Value = PN
TargetBook.ActiveSheet.Range("B13").Value = SN
TargetBook.ActiveSheet.Range("E9").Value = StartDate
TargetBook.ActiveSheet.Range("E10").Value = EndDate
TargetBook.ActiveSheet.Range("B14").Value = ProjectNumber
TargetBook.ActiveSheet.Range("B15").Value = Customer
TargetBook.ActiveSheet.PageSetup.PrintArea = "$A$1:$E$39"
TargetBook.Close True
'Add hyperlink
SourceBook.Sheets(ESN & "_SV" & SV).Hyperlinks.Add Anchor:=Range("A" & i), _
Address:=ToPath & NewName
Application.Wait (Now + TimeValue("00:00:01"))
Progress.PGB.Value = i - 5
Progress.Lbl.Caption = "File " & i - 5 & " of 22 copied."
Next i
Application.ScreenUpdating = True`
First thing first - declare each variable explicitly. E.g.:
Dim i as Long, j as Long, FSO As Object, SV as String, ESN as String and etc.
The way in your code - Dim i, j, SV, ESN, PartName, ToPath they are declared as variant.
Second thing second - try something really very small to debug further. E.g. write this small piece:
Sub TestMe()
With Worksheets(1)
.Hyperlinks.Add anchor:=.Range("A1"), Address:="C:\Users\UserName\Desktop\test.docx"
End With
End Sub
and check whether it works. If it doesn't, debug further, check whether cells are locked or anything similar.
I decided to learn VBA two weeks ago, and it's gone rather smooth. Now, however, I've encountered a problem I can't seem to solve on my own.
I've set up an excel document containing various modules. One of these modules extracts comments from a word document over to the excel sheet - which works as intended.
The problem is, I haven't been able to extract the first numbered header above each comment, which I'd very much like. Currently I have to do this manually after extracting the comments. As an example, I would like to also extract the first header and number above each comment, such as '2.1.1 Title'. If the comment is highlighting the header itself, it should be that header which is extracted as well.
I've tried a variety of things based on what I could find online, but every time I'm met with a variety of bugs I can't seem to fix. I've yet to find something that even sorta works. I did try one method which apparently should work in Word VBA, but I couldn't get it working within Excel.
Does anyone know how I would go about extracting the numbered headers? Any hints or tips will be greatly appreciated.
This is the code I have for the module:
Sub ImportCommentsDOCX()
Dim wdDoc As Object
Dim wdFileName As Variant
Dim i As Integer
wdFileName = Application.GetOpenFilename("Word files (*.docx),*.docx", , _
"Browse for file to be imported")
If wdFileName = False Then Exit Sub '(user cancelled import file browser)
Set wdDoc = GetObject(wdFileName) 'open Word file
'1: if no comments'
With wdDoc
If wdDoc.Comments.Count = 0 Then
MsgBox ("No comments")
End If
'2; Set excel headers'
Range("B" & 1).Value = "Number"
Range("B" & 1).Font.Bold = True
Range("C" & 1).Value = "Comment"
Range("C" & 1).Font.Bold = True
Range("D" & 1).Value = "Highlighted text"
Range("D" & 1).Font.Bold = True
Range("E" & 1).Value = "Initials"
Range("B" & 1).Font.Bold = True
Range("F" & 1).Value = "Date (*Imprecise)"
Range("F" & 1).Font.Bold = True
'3: Extract comments and meta data'
For i = 1 To wdDoc.Comments.Count
Range("B" & 1 + i).Value = wdDoc.Comments(i).Index
Range("C" & 1 + i).Value = wdDoc.Comments(i).Range
Range("D" & 1 + i).Value = wdDoc.Comments(i).Scope.FormattedText
Range("E" & 1 + i).Value = wdDoc.Comments(i).Initial
Range("F" & 1 + i).Value = Format(wdDoc.Comments(i).Date, "dd/MM/yyyy") 'Unreliable: Sometimes gives wrong date'
'Range("G" & 3 + i).Value = wdDoc.Comments(i).Range.ListFormat.ListString 'Returns empty'
Next i
End With
Set wdDoc = Nothing
MsgBox ("Extraction has completed")
End Sub
Here is your code with some adjustments:
Sub ImportCommentsDOCX()
Dim wdDoc As Object
Dim wdFileName As Variant
Dim i As Integer
wdFileName = Application.GetOpenFilename("Word files (*.docx),*.docx", , _
"Browse for file to be imported")
If wdFileName = False Then Exit Sub '(user cancelled import file browser)
Set wdDoc = GetObject(wdFileName) 'open Word file
'1: if no comments'
With wdDoc
wdDoc.Activate ' Added
If wdDoc.Comments.Count = 0 Then
MsgBox ("No comments")
End If
'2; Set excel headers'
Range("B" & 1).Value = "Number"
Range("B" & 1).Font.Bold = True
Range("C" & 1).Value = "Comment"
Range("C" & 1).Font.Bold = True
Range("D" & 1).Value = "Highlighted text"
Range("D" & 1).Font.Bold = True
Range("E" & 1).Value = "Initials"
Range("E" & 1).Font.Bold = True ' Modified
Range("F" & 1).Value = "Date (*Imprecise)"
Range("F" & 1).Font.Bold = True
'3: Extract comments and meta data'
For i = 1 To wdDoc.Comments.Count
Range("B" & 1 + i).Value = wdDoc.Comments(i).Index
Range("C" & 1 + i).Value = wdDoc.Comments(i).Range
Range("D" & 1 + i).Value = wdDoc.Comments(i).Scope.FormattedText
Range("E" & 1 + i).Value = wdDoc.Comments(i).Initial
Range("F" & 1 + i).Value = Format(wdDoc.Comments(i).Date, "dd/MM/yyyy") 'Unreliable: Sometimes gives wrong date'
'Range("G" & 1 + i).Value = wdDoc.Comments(i).Scope.ListFormat.ListString 'Returns empty' ' Modified ' Updated
Dim wp As Word.Paragraph: Set wp = wdDoc.Comments(i).Scope.Paragraphs(1) ' Updated
Do While wp.Range.ListFormat.ListString = "" ' Updated
Set wp = wp.Previous ' Updated
Loop ' Updated
Range("G" & 1 + i).Value = wp.Range.ListFormat.ListString ' Updated
Next i
End With
Set wdDoc = Nothing
MsgBox ("Extraction has completed")
End Sub
Please note my comments: Added and Modified
wdDoc.Activate was required at least on my computer, otherwise the
Range property is empty.
After initials a wrong column was bolded
The original text is referred to by the Range property, not the Scope (which is the content of the comment), so its ListFormat property should be used
The row index was not correct (3 instead of 1)
Looks working for me:
This requires Microsoft VBScript Regular Expression 5.5
Sub commentaires()
Dim regexOne As Object
Set regexOne = New RegExp
regexOne.Pattern = "^\d+\."
Dim s As String, s1 As String
Dim cmt As Word.Comment
Dim doc As Word.Document
For Each cmt In ActiveDocument.Comments
Dim wp As Word.Paragraph
Set wp = cmt.Scope.Paragraphs(1) ' Updated
Do While Not regexOne.Test(wp.Range.ListFormat.ListString)
Set wp = wp.Previous ' Updated
Loop ' Updated
s = s & _
wp.Range.ListFormat.ListString & ";" & _
cmt.Reference.Information(wdActiveEndAdjustedPageNumber) & ";""" & _
cmt.Scope & """;""" & _
cmt.Range.Text & """ " & vbCr
Next
Dim f As Integer
f = FreeFile
Open "c:\comments.csv" For Output As #f
Print #f, s
Close #f
End Sub