I need to develop a excel vba application to rename over hundred pdf file...
I have excel file, column A is content in pdf, column B is new name of pdf. if pdf content match with column A, then rename to new name in column B.
but there is a error - Method or data member not found (Error 461) in Function ExtractPDFContent(pdfFile As String) As String and highlighting 'GetText'
code below
Sub RenamePDF()
Dim wb As Workbook
Set wb = ThisWorkbook
Dim ws As Worksheet
Set ws = wb.Sheets("Sheet1")
Dim pdfPath As String
pdfPath = "F:\exceltest\"
Dim pdfFile As String
Dim pdfContent As String
Dim lastRow As Long
lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
Dim i As Long
For i = 1 To lastRow
pdfFile = pdfPath & ws.Cells(i, "A").Value & ".pdf"
If Dir(pdfFile) <> "" Then
pdfContent = ExtractPDFContent(pdfFile)
If pdfContent = ws.Cells(i, "A").Value Then
Name pdfFile As pdfPath & ws.Cells(i, "B").Value & ".pdf"
End If
End If
Next i
End Sub
**Function ExtractPDFContent(pdfFile As String) As String**
Dim pdfDoc As Acrobat.CAcroPDDoc
Set pdfDoc = CreateObject("Acrobat.PDDoc")
pdfDoc.Open (pdfFile)
Dim numPages As Long
numPages = pdfDoc.GetNumPages
Dim i As Long
Dim text As String
For i = 0 To numPages - 1
text = text & pdfDoc.**GetText**(i)
Next i
pdfDoc.Close
Set pdfDoc = Nothing
ExtractPDFContent = text
End Function
i asked ChatGPT before, it said missing Acrobat in reference, then check it all still not work
Related
I am trying to export multiple worksheets as an specific csv file with very specific formatting to feed into third party software (PJe Calc Cidadão).
PJe accepts files written in the following format:
"MES_ANO";"VALOR";"FGTS";"FGTS_REC.";"CONTRIBUICAO_SOCIAL";"CONTRIBUICAO_SOCIAL_REC."
"10/2012";"500,00";"S";"S";"S";"S"
"01/2013";"500,00";"S";"N";"S";"N"
I can achieve this formatting by concatenating formatted values in a single column of a worksheet and saving it as a CSV, but once I open the CSV outside excel it is formated as:
"""MES_ANO"";""VALOR"";""FGTS"";""FGTS_REC."";""CONTRIBUICAO_SOCIAL"";""CONTRIBUICAO_SOCIAL_REC."""
"""12/2015"";""1000,00"";""N"";""N"";""N"";""N"""
"""01/2016"";""1000,00"";""N"";""N"";""N"";""N"""
If I simply copy and paste the column in a txt file I can get the format that I want, but since I need to do that multiple times it's a bit tiring
Any advice?
Assuming you want to export Columns A to F on all the sheets in the workbook to separate csv files with unicode encoding then try this ;
Option Explicit
Sub exportcsv()
Const LAST_COL = 6
Const DELIM = ";"
Const QUOTE = """"
Dim wb As Workbook, ws As Worksheet
Dim iRow As Long, iLastRow As Long, s As String, c As Integer, count As Integer
Dim oFSO As Object, oFS As Object
Dim sPath As String, sCSVfile As String
Set oFSO = CreateObject("Scripting.FileSystemObject")
Set wb = ThisWorkbook
sPath = wb.path & "\"
For Each ws In wb.Sheets
count = 0
sCSVfile = "Sheet_" & ws.Index & ".csv"
Set oFS = oFSO.CreateTextFile(sPath & sCSVfile, True, True) 'overwrite, Unicode
iLastRow = ws.Cells(Rows.count, 1).End(xlUp).Row
For iRow = 1 To iLastRow
s = ""
For c = 1 To LAST_COL
If c > 1 Then s = s & DELIM
s = s & QUOTE & ws.Cells(iRow, c) & QUOTE
Next
oFS.writeline s
count = count + 1
Next
oFS.Close
Debug.Print sCSVfile, count
Next
MsgBox "CSV files exported to " & sPath, vbInformation, "Finished"
End Sub
I am trying to pull data from a worksheet in another workbook and it isn't working properly. I'm not getting an error in the code but it is not pulling the data from the worksheet I want but rather whatever worksheet is open when the workbook opens. I read somewhere that there is no need to activate the worksheet so I am not sure what is wrong with the following code:
Dim prfile1 As String
Dim prfile2 As String
Dim filepath As String
Dim checktotal As Integer
Dim checkrng As Range
Dim emunber As String
prfile1 = Worksheets("setup").Range("B10").Value
prfile2 = Worksheets("setup").Range("B7").Value
filepath = Worksheets("setup").Range("e10").Value
emunber = Worksheets("ReprintOld").Range("V3").Value
Workbooks.Open filepath & prfile2
Windows(prfile2).Activate
Sheets(emunber).Activate
checktotal = Workbooks(prfile2).Worksheets(emunber).Range("AE1")
With Workbooks(prfile2).Worksheets(emunber)
Set checkrng = Range(Range("U5"), Range("U" & 4 + checktotal).End(xlDown))
End With
Windows(prfile1).Activate
MsgBox emunber
MsgBox checktotal
MsgBox checkrng.Address
My problem is when closing workbook2 I need to use code to automatically select No on a message box that pops up. This is how my code is laid out:
Workbook1 creates multiple files based on user input.
The loop in Workbook1 opens up Workbook2 and inputs data from Workbook1.
When the loop is done inputing data it closes workbook2 and a message box pops up with a Yes or No button on it.
User at this time should always select No.
Another window ask if the user would like to save and it should always be yes.
Loop continues until it has created all the files user has requested
I tried googling variations of my question but have not had much luck. Any help is much appreciated.
Dim JobName As String
Dim lngLoop As Long
Dim i As Integer
Dim Customer As String
Dim LastRow As Long
Dim iCus As Integer
Dim CompanyName As String
Dim d As Long
Dim strDir As Variant
Dim DIV As String
Dim XL As Excel.Application
Dim WBK As Excel.Workbook
Dim ActSheet As Worksheet
Dim ActBook As Workbook
Dim CurrentFile As Workbook
Dim NewFileType As String
Dim NewFile As String
Dim QTR_NUM As String
Dim MFG As String
Dim Job As String
Dim visitdate As Variant
Dim visitdate_text As String
Dim Quote_Request As Worksheet
Dim QTR As Workbook
Dim QTRLOG As Workbook
Dim FORM As Workbook
Dim DCSProgram As Workbook
Dim ILast As Long
Dim j As Integer
Dim k As Integer
Dim CustomerIDNum As String
Dim QTRNUM As String
Dim FolderName As String
'Creates Quote For Each MFG
For j = 0 To QTRList.ListCount - 1
Set QTRLOG = Workbooks.Open("C:\QTR LOG.xlsm")
Set QTR = Workbooks.Open("C:\QTR.xlsx")
'CODE TO INPUT DATA FROM USERFORM NEW QTR
With DCSProgram.Sheets("MFG_DATA")
ILast = .Cells(.Rows.Count, 1).End(xlUp).Row
For i = 1 To ILast
If .Cells(i, 1).Value = MFG Then
QTR.Sheets(1).Range("B7").Value = .Cells(i, 2).Value
QTR.Sheets(1).Range("B8").Value = .Cells(i, 3).Value
QTR.Sheets(1).Range("B9").Value = .Cells(i, 4).Value
QTR.Sheets(1).Range("B12").Value = .Cells(i, 5).Value
QTR.Sheets(1).Range("B13").Value = .Cells(i, 6).Value
QTR.Sheets(1).Range("B14").Value = .Cells(i, 7).Value
QTR.Sheets(1).Range("B15").Value = .Cells(i, 8).Value
End If: Next: End With
With QTRLOG.Sheets("QTR_LOG")
ILast = .Cells(Rows.Count, 1).End(xlUp).Row
For i = 1 To ILast
If .Cells(i, 1).Value = QTR_NUM Then
.Cells(i, 2) = QTRList.List(j)
'.Cells(i, 3) = FORM.Sheets(1).Range("H11").Value
.Cells(i, 5) = JobName
.Cells(i, 8) = "OPEN"
.Cells(i, 9) = QTR.Sheets(1).Range("H9").Value
End If: Next: End With
QTRLOG.Save
QTRLOG.Close
QTR.SaveAs Filename:="C:\Users\Geoffrey\Dropbox\DCS PROGRAM\FILES\2. QUOTE REQUESTS\" & JobName & "\" _
& " DCS QTR " & QTRList.List(j) & " " & JobName & " (" & CustomerIDNum & ") " & visitdate_text & " .xlsx", _
FileFormat:=51, CreateBackup:=False, local:=True
'Code To Close File After Creating It
QTR.Close
Next j
End If
Application.ScreenUpdating = True
Call Shell("explorer.exe" & " " & "C:\Users\Geoffrey\Dropbox\DCS PROGRAM\FILES\2. QUOTE REQUESTS", vbNormalFocus)
Unload NewQTR
End Sub
When this code runs a msgbox appears from the workbook QTR. I dont want the user to have to click yes or no at this time. I want to automatically select No and continue on to the next file. This process is repeated for each MFG.
Code in QTR:
Application.ScreenUpdating = True
MSG1 = MsgBox("Are you ready to email to MFG?", vbYesNo, "EMAIL MFG")
If MSG1 = vbYes Then
'Code to create email and attached workbook as PDF
Else
Const kPath As String = "C:\"
Const kFile As String = "Users\Geoffrey\Dropbox\DCS PROGRAM\FILES\9. PROGRAM FILES\1. QUOTE REQUEST\QUOTE REQUEST LOG.xlsm"
Dim TOTALFOB As Double
Dim TOTALWC As Double
Dim Wbk As Workbook
Dim INWBK As Workbook
Dim QTR_NUM As String
Dim ILast As Long
Dim i As Long
Dim TOTMFG As Variant
Dim TOTWC As Variant
Dim LR As Long
Dim TOTALTIME As Variant
Set INWBK = ThisWorkbook
With Sheets("QTR")
LR = .Range("I" & Rows.Count).End(xlUp).Row
TOTALFOB = WorksheetFunction.Sum(.Range("I23:I" & LR))
End With
TOTALWC = TOTALFOB + INWBK.Sheets("QTR").Range("D18").Value
QTR_NUM = INWBK.Sheets("QTR").Range("H7").Value
TOTALTIME = INWBK.Sheets("WS_LOG").Range("J3").Value
Rem Set Wbk in case it's open
On Error Resume Next
Set Wbk = Workbooks(kFile)
On Error GoTo 0
Rem Validate Wbk
If Wbk Is Nothing Then Set Wbk = Workbooks.Open(kPath & kFile)
With Workbooks("QUOTE REQUEST LOG.xlsm").Sheets("QTR_LOG")
ILast = .Cells(Rows.Count, 1).End(xlUp).Row
For i = 1 To ILast
If .Cells(i, 1).Value = QTR_NUM Then
.Cells(i, 6) = TOTALFOB
.Cells(i, 7) = TOTALWC
.Cells(i, 10) = TOTALTIME
End If: Next: End With
Wbk.Save
Wbk.Close
End If
End Sub
If your problem is avoiding some Workbook_BeforeClose() event handler placed in "ThisWorkbook" code to be executed, then you must "enclose" the code lines that close the workbook like follows
Application.EnableEvents = False
' your code that closes the workbook
Application.EnableEvents = True
Exit Sub before end if is making the code exit earlier.
So remove the above mentioned one and check.
I have some csv files in one folder. They all contain 3 specific columns. The number of total columns and the order may vary.
I want to concatenate all 3 columns with an underscore and write them in a single column in the worksheet that is running the code.
Here is what I have so far:
Option Explicit
Sub test()
Dim i As Long
Dim LastRow As Long
Dim Columns()
Columns = Array("Column1", "Column2", "Column3")
'Find Columns by Name
For i = 0 To 2
Columns(i) = Rows(1).Find(What:=Columns(i), LookIn:=xlValues, LookAt:=xlWhole, _
MatchCase:=False, SearchFormat:=False).Column
Next i
'Debug.Print Columns(0)
'Debug.Print Columns(1)
'Debug.Print Columns(2)
LastRow = Cells(Rows.Count, "A").End(xlUp).Row
For i = 2 To LastRow
Cells(i, 1) = Cells(i, Columns(0)) & "_" & Cells(i, Columns(1)) & "_" & Cells(i, Columns(2))
Next i
End Sub
As you can see, this does what I want, but only for the active sheet.
I actually want to loop through all csv files in the same folder as the active sheet and write the results in the first sheet, first column of the sheet running the code (which is not a csv itself obviously).
How can I do this?
thanks!
This is a code that will loop through a folder
Sub Button1_Click()
Dim MyFile As String, Str As String, MyDir As String, Wb As Workbook
Set Wb = ThisWorkbook
'change the address to suite
MyDir = "C:\WorkBookLoop\"
MyFile = Dir(MyDir & "*.xls") 'change file extension
ChDir MyDir
Application.ScreenUpdating = 0
Application.DisplayAlerts = 0
Do While MyFile <> ""
Workbooks.Open (MyFile)
'do something here
MyFile = Dir()
Loop
End Sub
It depends how you are naming the worksheets you create from the CSV files. You could add all the worksheets to a collection and use a For...Each loop to execute the entire search and concatenate procedure within that loop. Note that you'd have to explicitly define the first sheet name as this won't change through successive loops:
Option Explicit
Sub test()
Dim i As Long
Dim LastRow As Long
Dim Columns()
Dim frontSheet as Worksheet
Dim wSheets as New Collection
Dim ws as Worksheet
Set frontSheet = Sheets("name of front sheet")
'Add all your CSV sheets to wSheets using the .Add() method.
For Each ws in wSheets
Columns = Array("Column1", "Column2", "Column3")
'Find Columns by Name
For i = 0 To 2
Columns(i) = ws.Rows(1).Find(What:=Columns(i), LookIn:=xlValues, LookAt:=xlWhole, _
MatchCase:=False, SearchFormat:=False).Column
Next i
'Debug.Print Columns(0)
'Debug.Print Columns(1)
'Debug.Print Columns(2)
LastRow = ws.Cells(Rows.Count, "A").End(xlUp).Row
For i = 2 To LastRow
frontsheet.Cells(i, 1) = ws.Cells(i, Columns(0)) & "_" & ws.Cells(i, Columns(1)) & "_" & ws.Cells(i, Columns(2))
Next i
Next ws
End Sub
It's often slow and labourious to open CSV files in excel but VBA can read them as text files using a TextStream. Furthermore, file scripting objects let you work with files and directories directly. Something like this might be a better approach if you don't need to keep the files in a worksheet afterwards:
Sub SearchFoldersForCSV()
Dim fso As Object
Dim fld As Object
Dim file As Object
Dim ts As Object
Dim strPath As String
Dim lineNumber As Integer
Dim lineArray() As String
Dim cols() As Integer
Dim i As Integer
Dim frontSheet As Worksheet
Dim frontSheetRow As Integer
Dim concatString As String
Set frontSheet = Sheets("name of front sheet")
frontSheetRow = 1
strPath = "C:\where-im-searching\"
Set fso = CreateObject("Scripting.FileSystemObject")
Set fld = fso.GetFolder(strPath)
For Each file In fld.Files
If (Right(file.Name, 3) = "csv") Then
Debug.Print file.Name
Set ts = file.OpenAsTextStream()
lineNumber = 0
Do While Not ts.AtEndOfStream
lineNumber = lineNumber + 1
lineArray = Split(ts.ReadLine, ",")
If (lineNumber = 1) Then
'We are at the first line of the .CSV so
'find index in lineArray of columns of interest
'Add extra ElseIf as required
For i = LBound(lineArray) To UBound(lineArray)
If lineArray(i) = "Column 1" Then
cols(1) = i
ElseIf lineArray(i) = "Column 2" Then
cols(2) = i
ElseIf lineArray(i) = "Column 3" Then
cols(3) = i
End If
Next i
Else
'Read and store the column of interest from this
'row by reading the lineArray indices found above.
concatString = ""
For i = LBound(cols) To UBound(cols)
concatString = concatString & lineArray(i) & "_"
Next i
concatString = Left(concatString, Len(concatString) - 1)
frontSheet.Cells(frontSheetRow, 1).Value = concatString
frontSheetRow = frontSheetRow + 1
End If
Loop
ts.Close
End If
Next file
End Sub
You can find more information on FileSystemObject and TextStream here.
I need to copy the excel sheets and make it into one consolidated excel workbook . After consolidating the worksheet , all files need to move to new folder called "Orginial".
The folder should be be created where the file is located.
Problem is file will be selected by the user itself
I am using getfilename to get the path from the user
Steps invloving :
Step1 : for example : if user needs to select
C :\my documents\worksheet1.xls
C :\my documents\worksheet2.xls
C :\my documents\worksheet3.xls
step2 :file should be consolidated as worksheet1.xls and
step3: folder should be created in the c:\my documents\original
and all worksheet1, worksheet2,worksheet3 , should move into "original" folder
I have code for consolidting the excelsheets . But i dont know how to create a folder within the path .Please help me
Below is the code
Option Explicit
Sub copyma()
Dim wb(20) As Variant
Dim ws(20) As Variant
Dim lastrow As Variant
Dim lastr(20) As Variant
Dim nextrow As Variant
Dim tempwb As Variant
Dim tempws As Worksheet
Dim tempfile As Variant
Dim fnum As Variant
Dim ws1 As Worksheet
Dim m As Integer
Dim ffiles(20) As Variant
Dim nextlastrow As Variant
Dim lastcopyrow As Variant
Dim lastcopycol As Variant
Set ws1 = Worksheets("sheet1")
fnum = ws1.Range("b3").Value
'selecting temporary files
MsgBox " plz select the temp sheet"
tempfile = Application.GetOpenFilename
Set tempwb = Workbooks.Open(Filename:=tempfile)
Set tempws = tempwb.Worksheets("sheet1")
tempws.Cells.Clear
' sleecting number of files
For m = 1 To fnum
MsgBox " Please Select " & m & "files"
ffiles(m) = Application.GetOpenFilename
Next m
' opening the files and copying to the temp sheet
For m = 1 To fnum
Set wb(m) = Workbooks.Open(Filename:=ffiles(m))
Set ws(m) = wb(m).Worksheets("sheet")
ws(m).AutoFilterMode = False
' finding the lastrow of the temp sheet
lastrow = tempws.Range("A" & tempws.Rows.Count).End(xlUp).Row
lastr(m) = ws(m).Range("A" & ws(m).Rows.Count).End(xlUp).Row
MsgBox lastr(m)
nextlastrow = lastrow + 1
With ws(m)
lastcopyrow = .Range("A" & .Rows.Count).End(xlUp).Row
lastcopycol = ws(m).Cells(1, .Columns.Count).End(xlToLeft).Column
' lastcol = ws2.Cells(1, .Columns.Count).End(xlToLeft).Column
If m = 1 Then
.Range("A1", .Cells(lastcopyrow, lastcopycol)).Copy tempws.Cells(lastrow, 1)
Else
.Range("A2", .Cells(lastcopyrow, lastcopycol)).Copy tempws.Cells(nextlastrow, 1)
End If
End With
wb(m).Close
Next m
tempws.Name = "sheet"
tempwb.Save
End Sub
'Get file path
Dim outfolder As String
outfolder = Mid(tmpfile, 1, InStrRev(tmpfile, "\")) & "original"
'Check if directory exists and create it if it does not
If Dir(outfolder) = "" Then
MkDir outfolder
End If
Considering you have the base path at your disposal:
Sub Create_Path()
Dim sBase_Path As String
Dim sNew_Path As String
sBase_Path = "U:\"
sNew_Path = sBase_Path & "New_Path" 'Define yourself
MkDir sNew_Path
End Sub