Option Explicit
Sub evenoddconditionalformatting()
'Dim days() As String
Sheets("Sheet1").Select
ActiveSheet.Cells.ClearFormats
'get the days in the days array
Dim selectioncells As Range
Range(Range("B1"), Range("B1").End(xlToRight)).Select
Set selectioncells = selection
'MsgBox (selection.Address)
'MsgBox (selection.Count)
Dim arraylength As Integer
ReDim days(selection.Count)
'MsgBox (UBound(days))
Dim cell As Range, i As Integer
i = 1
For Each cell In selectioncells
days(i) = cell.Value
i = i + 1
Next
Dim names() As String
Range("a2", Range("a2").End(xlDown)).Select
'MsgBox (selection.Count)
'Dim arraylength As Integer
Set selectioncells = selection
ReDim names(selectioncells.Count)
'MsgBox (UBound(days))
'Dim cell As Range, i As Integer
For i = 1 To selectioncells.Count
names(i) = selectioncells(i).Value
Next
'
' For i = 1 To UBound(names)
'
' MsgBox (names(i))
'
' Next i
'
Dim dict As Object 'Declare a generic Object reference
Set dict = CreateObject("Scripting.Dictionary") 'Late Binding of the Dictionary
For i = 1 To UBound(names)
Dim key, val
key = names(i): val = Application.RandBetween(0, 1)
'Add item to VBA Dictionary
If Not dict.Exists(key) Then
dict.Add key, val
End If
Next i
'
'Debug.Print dict.Count 'Result: 1
'
For Each key In dict.Keys
Debug.Print key
Next key
'
''Print all items
'For Each val In dict.Items
' Debug.Print val
'Next val
Range("L2").Select
For Each key In dict.Keys
'Debug.Print key
ActiveCell.Value = key
ActiveCell.Offset(0, 1).Value = dict(key)
ActiveCell.Offset(1, 0).Select
Next key
Set selectioncells = Range("B2:H11")
For Each cell In selectioncells
'Debug.Print cell.End(xlToLeft).Value
'Debug.Print cell.End(xlUp).Value
Dim pos As Integer
For i = 1 To UBound(days)
If cell.End(xlUp).Value = days(i) Then
pos = i
Exit For
End If
Next i
'MsgBox (pos)
pos = pos - 1
pos = pos Mod 2
'MsgBox (pos)
Dim pos2 As Integer
For Each key In dict.Keys
'Debug.Print key
If cell.End(xlToLeft).Value = key Then
pos2 = dict(key)
Exit For
End If
Next key
'MsgBox (pos2)
If pos = pos2 Then
cell.Value = "Should be present"
Else
cell.Value = "Should be absent"
End If
Next cell
ActiveSheet.Columns.AutoFit
Dim mydate As String
mydate = Format(Date, "dddd")
Range(Range("B1"), Range("B1").End(xlToRight)).Select
Set selectioncells = selection
For Each cell In selectioncells
If mydate = cell.Value Then
Range(cell, cell.End(xlDown)).Select
Exit For
End If
Next
Set selectioncells = selection
'MsgBox (selectioncells.Address)
For Each cell In selectioncells
If cell.Value Like "*present" Then
cell.Interior.ColorIndex = 44
Else
End If
'MsgBox (cell.Value)
Next
End Sub
Monday, June 29, 2020
Sunday, June 28, 2020
Delete single or multiple pages from pdf file automatically using VBA and Acrobat Pro
Option Explicit
Sub deletepagefrompdf()
Dim aapp As Acrobat.AcroApp
Dim todoc As Acrobat.AcroPDDoc
Set aapp = CreateObject("AcroExch.App")
Set todoc = CreateObject("AcroExch.PDDoc")
aapp.Show
todoc.Open ("C:\Users\allso\Desktop\excel_to_pdf\merged_firstpage.pdf")
If todoc.DeletePages(0, 1) = True Then
Debug.Print "Deleted"
Else
Debug.Print "Failed To Delete"
End If
If todoc.Save(PDSaveFull, "C:\Users\allso\Desktop\excel_to_pdf\edited_deleted_firstpage.pdf") = False Then
Debug.Print "Failed to save the file"
Else
Debug.Print "Saved"
End If
todoc.Close
aapp.Exit
Set aapp = Nothing
Set todoc = Nothing
'close the blank acrobat window
Dim sKillExcel As String
sKillExcel = "TASKKILL /F /IM Acrobat.exe"
Shell sKillExcel, vbHide
End Sub
Sub deletepagefrompdf()
Dim aapp As Acrobat.AcroApp
Dim todoc As Acrobat.AcroPDDoc
Set aapp = CreateObject("AcroExch.App")
Set todoc = CreateObject("AcroExch.PDDoc")
aapp.Show
todoc.Open ("C:\Users\allso\Desktop\excel_to_pdf\merged_firstpage.pdf")
If todoc.DeletePages(0, 1) = True Then
Debug.Print "Deleted"
Else
Debug.Print "Failed To Delete"
End If
If todoc.Save(PDSaveFull, "C:\Users\allso\Desktop\excel_to_pdf\edited_deleted_firstpage.pdf") = False Then
Debug.Print "Failed to save the file"
Else
Debug.Print "Saved"
End If
todoc.Close
aapp.Exit
Set aapp = Nothing
Set todoc = Nothing
'close the blank acrobat window
Dim sKillExcel As String
sKillExcel = "TASKKILL /F /IM Acrobat.exe"
Shell sKillExcel, vbHide
End Sub
Combine pdfs together automatically using VBA and Acrobat Pro
Option Explicit
Sub combine_pdf_files()
Dim aapp As Acrobat.AcroApp
Dim todoc As Acrobat.AcroPDDoc
Dim fromdoc As Acrobat.AcroPDDoc
Set aapp = CreateObject("AcroExch.App")
Set todoc = CreateObject("AcroExch.PDDoc")
Set fromdoc = CreateObject("AcroExch.PDDOc")
aapp.Show
todoc.Open ("C:\Users\allso\Desktop\blank_pdf.pdf")
fromdoc.Open ("C:\Users\allso\Desktop\201753431466049.pdf")
If todoc.InsertPages(-1, fromdoc, 0, fromdoc.GetNumPages(), True) = False Then
'Here by using -1 we are trying to copy the frompdf to the first
'page of topdf,if the number is 0 it will be the next page from the first,if it is 1 it will be the second page from beginning
Debug.Print "Failed to insert the page"
End If
If todoc.Save(PDSaveFull, "C:\Users\allso\Desktop\excel_to_pdf\merged_firstpage.pdf") = False Then
Debug.Print "Failed to save the file"
Else
Debug.Print "Saved"
End If
todoc.Close
fromdoc.Close
aapp.Exit
Set aapp = Nothing
Set todoc = Nothing
Set fromdoc = Nothing
Sub combine_pdf_files()
Dim aapp As Acrobat.AcroApp
Dim todoc As Acrobat.AcroPDDoc
Dim fromdoc As Acrobat.AcroPDDoc
Set aapp = CreateObject("AcroExch.App")
Set todoc = CreateObject("AcroExch.PDDoc")
Set fromdoc = CreateObject("AcroExch.PDDOc")
aapp.Show
todoc.Open ("C:\Users\allso\Desktop\blank_pdf.pdf")
fromdoc.Open ("C:\Users\allso\Desktop\201753431466049.pdf")
If todoc.InsertPages(-1, fromdoc, 0, fromdoc.GetNumPages(), True) = False Then
'Here by using -1 we are trying to copy the frompdf to the first
'page of topdf,if the number is 0 it will be the next page from the first,if it is 1 it will be the second page from beginning
Debug.Print "Failed to insert the page"
End If
If todoc.Save(PDSaveFull, "C:\Users\allso\Desktop\excel_to_pdf\merged_firstpage.pdf") = False Then
Debug.Print "Failed to save the file"
Else
Debug.Print "Saved"
End If
todoc.Close
fromdoc.Close
aapp.Exit
Set aapp = Nothing
Set todoc = Nothing
Set fromdoc = Nothing
'closing the blank window of Acrobat
Dim sKillExcel As String
sKillExcel = "TASKKILL /F /IM Acrobat.exe"
Shell sKillExcel, vbHide
End Sub
Dim sKillExcel As String
sKillExcel = "TASKKILL /F /IM Acrobat.exe"
Shell sKillExcel, vbHide
End Sub
Saturday, June 27, 2020
Kill a running process(In my case it is acrobat) using VBA
Sub test2()
Dim sKillExcel As String
sKillExcel = "TASKKILL /F /IM Acrobat.exe"
Shell sKillExcel, vbHide
Dim sKillExcel As String
sKillExcel = "TASKKILL /F /IM Acrobat.exe"
Shell sKillExcel, vbHide
End Sub
Source:https://stackoverflow.com/questions/26303173/how-can-i-kill-task-manager-processes-through-vba-code
Friday, June 26, 2020
Automated multiple PDF files batch data entry using VBA and Acrobat Library
Option Explicit
Public Const pdf_form_file As String = "C:\Users\allso\Desktop\New Customer Registration Form.pdf"
Sub readpdfformfield()
Sheets("PDF_Form_Fields").Select
Cells.Clear
Dim eapp As Acrobat.AcroApp
Dim av_doc As Acrobat.AcroAVDoc
Dim pdf_form As AFORMAUTLib.AFormApp
Dim pdf_form_flds As AFORMAUTLib.Fields
Dim pdf_form_fld As AFORMAUTLib.Field
Dim rng, firstcell As Range
Dim rownum, colnum As Integer
rownum = 1: colnum = 1
Set eapp = CreateObject("AcroExch.App")
Set av_doc = CreateObject("AcroExch.AVDoc")
If av_doc.Open(pdf_form_file, "") = True Then
av_doc.BringToFront
eapp.Hide
Set pdf_form = CreateObject("AFORMAUT.App")
Set pdf_form_flds = pdf_form.Fields
For Each pdf_form_fld In pdf_form_flds
With pdf_form_fld
'Debug.Print .Name & "|" & .Type & "|" & .Value
Cells(rownum, colnum) = .Name & "|" & .Type & "|" & .Value
Cells(rownum, colnum).Select
Set rng = Cells(rownum, colnum)
'MsgBox (rng.Address)
'rng.TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar _
:="|", TrailingMinusNumbers:=True
Set firstcell = Cells(rownum, rng.Column)
'MsgBox (firstcell.Address)
rng.TextToColumns Destination:=firstcell, DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar _
:="|", TrailingMinusNumbers:=True
rownum = rownum + 1
End With
Next pdf_form_fld
av_doc.Close False
End If
eapp.Exit
Set av_doc = Nothing
Set eapp = Nothing
End Sub
Sub write_to_pdf_form()
Dim filenamepart As Integer
filenamepart = 1
Sheets("DataForPDF").Select
Range("A1").Select
Dim startrange As Range
Set startrange = Selection
While ActiveCell.Value <> ""
Dim pdfapp As Acrobat.AcroApp
Dim pdfdoc As Acrobat.AcroAVDoc
Dim support_doc As Acrobat.AcroPDDoc
Dim pdf_form As AFORMAUTLib.AFormApp
Dim pdf_form_flds As AFORMAUTLib.Fields
Dim givenname As AFORMAUTLib.Field
Dim familyname As AFORMAUTLib.Field
Dim address1 As AFORMAUTLib.Field
Dim phonenumber As AFORMAUTLib.Field
Dim findsource As AFORMAUTLib.Field
Dim email As AFORMAUTLib.Field
Dim willingtorecommend As AFORMAUTLib.Field
Set pdfapp = CreateObject("AcroExch.App")
Set pdfdoc = CreateObject("AcroExch.AVDoc")
If pdfdoc.Open(pdf_form_file, "") = True Then
pdfdoc.BringToFront
pdfapp.Hide
Set pdf_form = CreateObject("AFORMAUT.App")
Set pdf_form_flds = pdf_form.Fields
Set givenname = pdf_form.Fields("fullName3[first]")
Set familyname = pdf_form.Fields("fullName3[last]")
Set address1 = pdf_form.Fields("address4[addr_line1]")
Set phonenumber = pdf_form.Fields("phoneNumber5[full]")
Set email = pdf_form.Fields("email6")
Set findsource = pdf_form.Fields("howDid8")
Set willingtorecommend = pdf_form.Fields("willYou[0]")
Sheets("DataForPDF").Select
Cells(filenamepart, 1).Select
givenname.Value = ActiveCell.Value
familyname.Value = ActiveCell.Offset(0, 1).Value
address1.Value = ActiveCell.Offset(0, 2).Value
phonenumber.Value = ActiveCell.Offset(0, 3).Value
email.Value = ActiveCell.Offset(0, 4).Value
findsource.Value = ActiveCell.Offset(0, 5).Value
willingtorecommend.Value = ActiveCell.Offset(0, 6).Value
Set support_doc = pdfdoc.GetPDDoc
Dim path As String
path = "C:\Users\allso\Desktop\excel_to_pdf\output_" & filenamepart & ".pdf"
filenamepart = filenamepart + 1
'MsgBox (path)
If support_doc.Save(PDSaveFull, path) Then
Debug.Print "Saved"
Else
Debug.Print "Failed to save"
End If
pdfdoc.Close True
support_doc.Close
pdfapp.Exit
Set givenname = Nothing
Set familyname = Nothing
Set address1 = Nothing
Set phonenumber = Nothing
Set email = Nothing
Set findsource = Nothing
Set willingtorecommend = Nothing
Set pdfdoc = Nothing
Set support_doc = Nothing
End If
Wend
End Sub
Public Const pdf_form_file As String = "C:\Users\allso\Desktop\New Customer Registration Form.pdf"
Sub readpdfformfield()
Sheets("PDF_Form_Fields").Select
Cells.Clear
Dim eapp As Acrobat.AcroApp
Dim av_doc As Acrobat.AcroAVDoc
Dim pdf_form As AFORMAUTLib.AFormApp
Dim pdf_form_flds As AFORMAUTLib.Fields
Dim pdf_form_fld As AFORMAUTLib.Field
Dim rng, firstcell As Range
Dim rownum, colnum As Integer
rownum = 1: colnum = 1
Set eapp = CreateObject("AcroExch.App")
Set av_doc = CreateObject("AcroExch.AVDoc")
If av_doc.Open(pdf_form_file, "") = True Then
av_doc.BringToFront
eapp.Hide
Set pdf_form = CreateObject("AFORMAUT.App")
Set pdf_form_flds = pdf_form.Fields
For Each pdf_form_fld In pdf_form_flds
With pdf_form_fld
'Debug.Print .Name & "|" & .Type & "|" & .Value
Cells(rownum, colnum) = .Name & "|" & .Type & "|" & .Value
Cells(rownum, colnum).Select
Set rng = Cells(rownum, colnum)
'MsgBox (rng.Address)
'rng.TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar _
:="|", TrailingMinusNumbers:=True
Set firstcell = Cells(rownum, rng.Column)
'MsgBox (firstcell.Address)
rng.TextToColumns Destination:=firstcell, DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar _
:="|", TrailingMinusNumbers:=True
rownum = rownum + 1
End With
Next pdf_form_fld
av_doc.Close False
End If
eapp.Exit
Set av_doc = Nothing
Set eapp = Nothing
End Sub
Sub write_to_pdf_form()
Dim filenamepart As Integer
filenamepart = 1
Sheets("DataForPDF").Select
Range("A1").Select
Dim startrange As Range
Set startrange = Selection
While ActiveCell.Value <> ""
Dim pdfapp As Acrobat.AcroApp
Dim pdfdoc As Acrobat.AcroAVDoc
Dim support_doc As Acrobat.AcroPDDoc
Dim pdf_form As AFORMAUTLib.AFormApp
Dim pdf_form_flds As AFORMAUTLib.Fields
Dim givenname As AFORMAUTLib.Field
Dim familyname As AFORMAUTLib.Field
Dim address1 As AFORMAUTLib.Field
Dim phonenumber As AFORMAUTLib.Field
Dim findsource As AFORMAUTLib.Field
Dim email As AFORMAUTLib.Field
Dim willingtorecommend As AFORMAUTLib.Field
Set pdfapp = CreateObject("AcroExch.App")
Set pdfdoc = CreateObject("AcroExch.AVDoc")
If pdfdoc.Open(pdf_form_file, "") = True Then
pdfdoc.BringToFront
pdfapp.Hide
Set pdf_form = CreateObject("AFORMAUT.App")
Set pdf_form_flds = pdf_form.Fields
Set givenname = pdf_form.Fields("fullName3[first]")
Set familyname = pdf_form.Fields("fullName3[last]")
Set address1 = pdf_form.Fields("address4[addr_line1]")
Set phonenumber = pdf_form.Fields("phoneNumber5[full]")
Set email = pdf_form.Fields("email6")
Set findsource = pdf_form.Fields("howDid8")
Set willingtorecommend = pdf_form.Fields("willYou[0]")
Sheets("DataForPDF").Select
Cells(filenamepart, 1).Select
givenname.Value = ActiveCell.Value
familyname.Value = ActiveCell.Offset(0, 1).Value
address1.Value = ActiveCell.Offset(0, 2).Value
phonenumber.Value = ActiveCell.Offset(0, 3).Value
email.Value = ActiveCell.Offset(0, 4).Value
findsource.Value = ActiveCell.Offset(0, 5).Value
willingtorecommend.Value = ActiveCell.Offset(0, 6).Value
Set support_doc = pdfdoc.GetPDDoc
Dim path As String
path = "C:\Users\allso\Desktop\excel_to_pdf\output_" & filenamepart & ".pdf"
filenamepart = filenamepart + 1
'MsgBox (path)
If support_doc.Save(PDSaveFull, path) Then
Debug.Print "Saved"
Else
Debug.Print "Failed to save"
End If
pdfdoc.Close True
support_doc.Close
pdfapp.Exit
Set givenname = Nothing
Set familyname = Nothing
Set address1 = Nothing
Set phonenumber = Nothing
Set email = Nothing
Set findsource = Nothing
Set willingtorecommend = Nothing
Set pdfdoc = Nothing
Set support_doc = Nothing
End If
Wend
End Sub
Get the first cell of a range in VBA
Sub test()
Dim rng As Range
Set rng = Cells(1, 1)
Dim rng2 As Range
'MsgBox (Range(Cells(1, rng.Column)))
Set rng2 = Cells(1, rng.Column)
MsgBox (rng2.Address)
End Sub
Dim rng As Range
Set rng = Cells(1, 1)
Dim rng2 As Range
'MsgBox (Range(Cells(1, rng.Column)))
Set rng2 = Cells(1, rng.Column)
MsgBox (rng2.Address)
End Sub
Read Form fields from pdf using acrobat pro library and write them in excel and perform a texttocolumns operation for every time the loop rotates using VBA
I already add a reference of adobe acrobat 10.0 type library,I also need to add AForm Aut 1.0 Type Library reference to my project
Option Explicit
Public Const pdf_form_file As String = "C:\Users\allso\Desktop\Business Loan Application Form.pdf"Sub readpdfformfield()
Sheets("PDF_Form_Fields").Select
Cells.Clear
Dim eapp As Acrobat.AcroApp
Dim av_doc As Acrobat.AcroAVDoc
Dim pdf_form As AFORMAUTLib.AFormApp
Dim pdf_form_flds As AFORMAUTLib.Fields
Dim pdf_form_fld As AFORMAUTLib.Field
Dim rng, firstcell As Range
Dim rownum, colnum As Integer
rownum = 1: colnum = 1
Set eapp = CreateObject("AcroExch.App")
Set av_doc = CreateObject("AcroExch.AVDoc")
If av_doc.Open(pdf_form_file, "") = True Then
av_doc.BringToFront
eapp.Hide
Set pdf_form = CreateObject("AFORMAUT.App")
Set pdf_form_flds = pdf_form.Fields
For Each pdf_form_fld In pdf_form_flds
With pdf_form_fld
'Debug.Print .Name & "|" & .Type & "|" & .Value
Cells(rownum, colnum) = .Name & "|" & .Type & "|" & .Value
Cells(rownum, colnum).Select
Set rng = Cells(rownum, colnum)
'MsgBox (rng.Address)
'rng.TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar _
:="|", TrailingMinusNumbers:=True
Set firstcell = Cells(rownum, rng.Column)
'MsgBox (firstcell.Address)
rng.TextToColumns Destination:=firstcell, DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar _
:="|", TrailingMinusNumbers:=True
rownum = rownum + 1
End With
Next pdf_form_fld
av_doc.Close False
End If
eapp.Exit
Set av_doc = Nothing
Set eapp = Nothing
End Sub
Performing Text to Column automatically using VBA
I have a string variable containing a string which contains lots of "|" character,I need to do a text to column using VBA,My string variable in in cell A1
Sub Macro1()
'
' Macro1 Macro
'
'
Dim rng As Range
Set rng = Range("A1")
Selection.TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar _
:="|", TrailingMinusNumbers:=True
' Selection.TextToColumns _
' Destination:=Range("A2"), _
' DataType:=xlDelimited, _
' TextQualifier:=xlDoubleQuote, _
' ConsecutiveDelimiter:=False, _
' Tab:=True, _
' Semicolon:=False, _
' Comma:=False, _
' Space:=False, _
' Other:=True, _
' OtherChar:="-"
End Sub
'
' Macro1 Macro
'
'
Dim rng As Range
Set rng = Range("A1")
Selection.TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar _
:="|", TrailingMinusNumbers:=True
' Selection.TextToColumns _
' Destination:=Range("A2"), _
' DataType:=xlDelimited, _
' TextQualifier:=xlDoubleQuote, _
' ConsecutiveDelimiter:=False, _
' Tab:=True, _
' Semicolon:=False, _
' Comma:=False, _
' Space:=False, _
' Other:=True, _
' OtherChar:="-"
End Sub
Read Table from pdf using acrobat pro and vba
Option Explicit
Public Const pdf_file As String = "C:\Users\allso\Desktop\table.pdf"
Sub pdftoexcel()
Dim eapp As Acrobat.AcroApp
Dim av_doc As CAcroAVDoc
Dim pdf_doc As CAcroPDDoc
Dim sel_text As CAcroPDTextSelect
Dim i, j As Long
Dim pagenumber, pagecontent, content
Dim data_print As Boolean
Dim cnt As Long
Dim currow As Long
currow = 1
Sheets("PDF_To_Excel").Select
Cells.Clear
Set eapp = CreateObject("AcroExch.App")
Set av_doc = CreateObject("AcroExch.AVDoc")
If av_doc.Open(pdf_file, vbNull) <> True Then Exit Sub
While av_doc Is Nothing
Set av_doc = eapp.GetActiveDoc
Wend
Set pdf_doc = av_doc.GetPDDoc
For i = 0 To pdf_doc.GetNumPages - 1
Set pagenumber = pdf_doc.AcquirePage(i)
Set pagecontent = CreateObject("AcroExch.HiliteList")
On Error Resume Next
If pagecontent.Add(0, 9000) <> True Then Exit Sub
Set sel_text = pagenumber.CreatePageHilite(pagecontent)
On Error GoTo 0
For j = 0 To sel_text.GetNumText - 1
'Debug.Print sel_text.GetText(j)
'content = sel_text.GetNumText(j)
content = sel_text.GetText(j)
If content Like "*Disability*" Then
data_print = True
ElseIf content Like "*Postal*" Then
data_print = False
Exit For
End If
If data_print = True Then
cnt = cnt + 1
Cells(currow, cnt) = Application.WorksheetFunction.Clean(Trim(content))
'Debug.Print content
End If
If cnt = 6 Then
cnt = 0
currow = currow + 1
End If
'Range("A" & Rows.Count).End(xlUp).Offset(1, 0).Value = sel_text.GetText(j)
Next j
Next i
av_doc.Close False
eapp.Exit
Set sel_text = Nothing
Set pagenumber = Nothing
Set eapp = Nothing
Set av_doc = Nothing
Set pdf_doc = Nothing
End Sub
Public Const pdf_file As String = "C:\Users\allso\Desktop\table.pdf"
Sub pdftoexcel()
Dim eapp As Acrobat.AcroApp
Dim av_doc As CAcroAVDoc
Dim pdf_doc As CAcroPDDoc
Dim sel_text As CAcroPDTextSelect
Dim i, j As Long
Dim pagenumber, pagecontent, content
Dim data_print As Boolean
Dim cnt As Long
Dim currow As Long
currow = 1
Sheets("PDF_To_Excel").Select
Cells.Clear
Set eapp = CreateObject("AcroExch.App")
Set av_doc = CreateObject("AcroExch.AVDoc")
If av_doc.Open(pdf_file, vbNull) <> True Then Exit Sub
While av_doc Is Nothing
Set av_doc = eapp.GetActiveDoc
Wend
Set pdf_doc = av_doc.GetPDDoc
For i = 0 To pdf_doc.GetNumPages - 1
Set pagenumber = pdf_doc.AcquirePage(i)
Set pagecontent = CreateObject("AcroExch.HiliteList")
On Error Resume Next
If pagecontent.Add(0, 9000) <> True Then Exit Sub
Set sel_text = pagenumber.CreatePageHilite(pagecontent)
On Error GoTo 0
For j = 0 To sel_text.GetNumText - 1
'Debug.Print sel_text.GetText(j)
'content = sel_text.GetNumText(j)
content = sel_text.GetText(j)
If content Like "*Disability*" Then
data_print = True
ElseIf content Like "*Postal*" Then
data_print = False
Exit For
End If
If data_print = True Then
cnt = cnt + 1
Cells(currow, cnt) = Application.WorksheetFunction.Clean(Trim(content))
'Debug.Print content
End If
If cnt = 6 Then
cnt = 0
currow = currow + 1
End If
'Range("A" & Rows.Count).End(xlUp).Offset(1, 0).Value = sel_text.GetText(j)
Next j
Next i
av_doc.Close False
eapp.Exit
Set sel_text = Nothing
Set pagenumber = Nothing
Set eapp = Nothing
Set av_doc = Nothing
Set pdf_doc = Nothing
End Sub
Wednesday, June 24, 2020
Get text data from pdf to excel range using acrobat library in VBA
First we need to add the acrobat reference and see if Adobe Acrobat 10.0 Type Library is enabled
Option Explicit
Public Const pdf_file As String = "C:\Users\allso\Desktop\Business Loan Application Form.pdf"Sub pdftoexcel()
Dim eapp As Acrobat.AcroApp
Dim av_doc As CAcroAVDoc
Dim pdf_doc As CAcroPDDoc
Dim sel_text As CAcroPDTextSelect
Dim i, j As Long
Dim pagenumber, pagecontent, content
Set eapp = CreateObject("AcroExch.App")
Set av_doc = CreateObject("AcroExch.AVDoc")
If av_doc.Open(pdf_file, vbNull) <> True Then Exit Sub
While av_doc Is Nothing
Set av_doc = eapp.GetActiveDoc
Wend
Set pdf_doc = av_doc.GetPDDoc
For i = 0 To pdf_doc.GetNumPages - 1
Set pagenumber = pdf_doc.AcquirePage(i)
Set pagecontent = CreateObject("AcroExch.HiliteList")
On Error Resume Next
If pagecontent.Add(0, 9000) <> True Then Exit Sub
Set sel_text = pagenumber.CreatePageHilite(pagecontent)
On Error GoTo 0
For j = 0 To sel_text.GetNumText - 1
'Debug.Print sel_text.GetText(j)
Range("A" & Rows.Count).End(xlUp).Offset(1, 0).Value = sel_text.GetText(j)
Next j
Next i
av_doc.Close False
eapp.Exit
Set sel_text = Nothing
Set pagenumber = Nothing
Set eapp = Nothing
Set av_doc = Nothing
Set pdf_doc = Nothing
End Sub
Sunday, June 21, 2020
Check if a folder exists in a path ,if not create it,then save all the sheets in a workbook in that folder with a name containing workbookname and current time in "yyyymmdd\_hhmmss" format
Option Explicit
Function Path_Exists(Path As String) As String
'Dim Path As String
Dim Folder As String
Dim Answer As VbMsgBoxResult
' Path = "C:\Users\allso\Desktop\excel_to_pdf"
Folder = dir(Path, vbDirectory)
' MsgBox (Path)
' MsgBox (Folder)
If Folder = vbNullString Then
Answer = MsgBox("Path does not exist. Would you like to create it?", vbYesNo, "Create Path?")
Select Case Answer
Case vbYes
VBA.FileSystem.MkDir (Path)
Case Else
Exit Function
End Select
Else
' MsgBox "Folder exists."
End If
Path_Exists = Path
End Function
Sub vba_excel_to_pdf()
'Path_Exists ("C:\Users\allso\Desktop\excel_to_pdf")
Dim output_file As String, ws_count, I As Integer
'output_file = ThisWorkbook.Path & "\" & Left(ThisWorkbook.Name, Len(ThisWorkbook.Name) - 5) & ".pdf"
'MsgBox (output_file)
'Set the location where the pdfs will be saved
'Dim pdffolder As FileDialog
'
'
'
'
'Set pdffolder = Application.FileDialog(msoFileDialogFolderPicker)
'pdffolder.AllowMultiSelect = False
'pdffolder.Show
'
'
Dim dir As String
'dir = pdffolder.SelectedItems(1)
dir = Path_Exists("C:\Users\allso\Desktop\excel_to_pdf")
'MsgBox (dir)
Dim strtime As String
' ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=dir & "\" & customer_code & ".pdf", openafterpublish:=False
' Set WS_Count equal to the number of worksheets in the active
ws_count = ActiveWorkbook.Worksheets.Count
' Begin the loop.
For I = 1 To ws_count
' Insert your code here.
' The following line shows how to reference a sheet within
' the loop by displaying the worksheet name in a dialog box.
' MsgBox ActiveWorkbook.Worksheets(I).Name
strtime = Format(Now(), "yyyymmdd\_hhmmss")
' MsgBox (strtime)
output_file = dir & "\" & Left(ThisWorkbook.Name, Len(ThisWorkbook.Name) - 5) & "." & ActiveWorkbook.Worksheets(I).Name & "." & strtime & ".pdf"
'MsgBox (output_file)
ActiveWorkbook.Worksheets(I).ExportAsFixedFormat xlTypePDF, output_file, xlQualityStandard, openafterpublish:=False
'ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=output_file, openafterpublish:=False
Next I
End Sub
Source:https://www.contextures.com/excelvbapdf.html
Function Path_Exists(Path As String) As String
'Dim Path As String
Dim Folder As String
Dim Answer As VbMsgBoxResult
' Path = "C:\Users\allso\Desktop\excel_to_pdf"
Folder = dir(Path, vbDirectory)
' MsgBox (Path)
' MsgBox (Folder)
If Folder = vbNullString Then
Answer = MsgBox("Path does not exist. Would you like to create it?", vbYesNo, "Create Path?")
Select Case Answer
Case vbYes
VBA.FileSystem.MkDir (Path)
Case Else
Exit Function
End Select
Else
' MsgBox "Folder exists."
End If
Path_Exists = Path
End Function
Sub vba_excel_to_pdf()
'Path_Exists ("C:\Users\allso\Desktop\excel_to_pdf")
Dim output_file As String, ws_count, I As Integer
'output_file = ThisWorkbook.Path & "\" & Left(ThisWorkbook.Name, Len(ThisWorkbook.Name) - 5) & ".pdf"
'MsgBox (output_file)
'Set the location where the pdfs will be saved
'Dim pdffolder As FileDialog
'
'
'
'
'Set pdffolder = Application.FileDialog(msoFileDialogFolderPicker)
'pdffolder.AllowMultiSelect = False
'pdffolder.Show
'
'
Dim dir As String
'dir = pdffolder.SelectedItems(1)
dir = Path_Exists("C:\Users\allso\Desktop\excel_to_pdf")
'MsgBox (dir)
Dim strtime As String
' ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=dir & "\" & customer_code & ".pdf", openafterpublish:=False
' Set WS_Count equal to the number of worksheets in the active
ws_count = ActiveWorkbook.Worksheets.Count
' Begin the loop.
For I = 1 To ws_count
' Insert your code here.
' The following line shows how to reference a sheet within
' the loop by displaying the worksheet name in a dialog box.
' MsgBox ActiveWorkbook.Worksheets(I).Name
strtime = Format(Now(), "yyyymmdd\_hhmmss")
' MsgBox (strtime)
output_file = dir & "\" & Left(ThisWorkbook.Name, Len(ThisWorkbook.Name) - 5) & "." & ActiveWorkbook.Worksheets(I).Name & "." & strtime & ".pdf"
'MsgBox (output_file)
ActiveWorkbook.Worksheets(I).ExportAsFixedFormat xlTypePDF, output_file, xlQualityStandard, openafterpublish:=False
'ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=output_file, openafterpublish:=False
Next I
End Sub
Source:https://www.contextures.com/excelvbapdf.html
check if a folder exists in a path and if not create the folder in that path on user prompt using vba
Sub Path_Exists()
Dim Path As String
Dim Folder As String
Dim Answer As VbMsgBoxResult
Path = "C:\Users\allso\Desktop\excel_to_pdf"
Folder = dir(Path, vbDirectory)
If Folder = vbNullString Then
Answer = MsgBox("Path does not exist. Would you like to create it?", vbYesNo, "Create Path?")
Select Case Answer
Case vbYes
VBA.FileSystem.MkDir (Path)
Case Else
Exit Sub
End Select
Else
MsgBox "Folder exists."
End If
End Sub
Dim Path As String
Dim Folder As String
Dim Answer As VbMsgBoxResult
Path = "C:\Users\allso\Desktop\excel_to_pdf"
Folder = dir(Path, vbDirectory)
If Folder = vbNullString Then
Answer = MsgBox("Path does not exist. Would you like to create it?", vbYesNo, "Create Path?")
Select Case Answer
Case vbYes
VBA.FileSystem.MkDir (Path)
Case Else
Exit Sub
End Select
Else
MsgBox "Folder exists."
End If
End Sub
Friday, June 19, 2020
Create a clustered bar chart using vba
This is my Source Data
I need to create a clustered bar chart using this data as source
to do this
Option Explicit
Sub chartcreationpart1()
'Declare some variables
Dim Chrt As ChartObject
Dim DataRng As Range
'Add a chart object, this would be an empty shell
Set Chrt = ActiveSheet.ChartObjects.Add(Left:=400, _
Width:=800, _
Height:=800, _
Top:=50)
'Define the data to be used in the chart.
Set DataRng = Range("A1").CurrentRegion
Chrt.Chart.SetSourceData Source:=DataRng
'Define the type of chart it is.
Chrt.Chart.ChartType = xlBarClustered
'Lets add a title
Chrt.Chart.HasTitle = True
'Create a reference to that title
Dim ChrtTitle As ChartTitle
Set ChrtTitle = Chrt.Chart.ChartTitle
'Do some formatting with the title.
ChrtTitle.Text = "Performance"
ChrtTitle.Shadow = False
ChrtTitle.Characters.Font.Bold = False
ChrtTitle.Characters.Font.Name = "Arial Nova"
'Add a legend to the chart
Chrt.Chart.HasLegend = True
'Create a reference to that legend
Dim ChrtLeg As Legend
Set ChrtLeg = Chrt.Chart.Legend
'Do some formatting
ChrtLeg.Position = xlLegendPositionTop
ChrtLeg.Height = 20
'Remove the gridlines
Chrt.Chart.SetElement msoElementPrimaryCategoryGridLinesNone
Chrt.Chart.SetElement msoElementPrimaryValueGridLinesNone
'Make sure the chart has some axes, it's usually true by default
Chrt.Chart.HasAxis(xlCategory, xlPrimary) = True
Chrt.Chart.HasAxis(xlValue, xlPrimary) = True
'Make sure each axis has a title
Chrt.Chart.Axes(xlValue, xlPrimary).HasTitle = True
Chrt.Chart.Axes(xlCategory, xlPrimary).HasTitle = True
'Take the newly created title and create a reference to it.
Dim AxisTitle As AxisTitle
Set AxisTitle = Chrt.Chart.Axes(xlCategory, xlPrimary).AxisTitle
'Do some formatting.
AxisTitle.Text = "Years"
AxisTitle.HorizontalAlignment = xlCenter
AxisTitle.Characters.Font.Color = vbRed
Set AxisTitle = Chrt.Chart.Axes(xlValue, xlPrimary).AxisTitle
'Do some formatting.
AxisTitle.Text = "Profit/Cost/Sales"
AxisTitle.HorizontalAlignment = xlCenter
AxisTitle.Characters.Font.Color = vbRed
End Sub
The output chart is
Thursday, June 18, 2020
Conditional Formatting periodically using VBA macro
Sub conditionsuperfinal()
Sheets("conditionalformattingvba").Select
Dim dict As Object 'Declare a generic Object reference
Set dict = CreateObject("Scripting.Dictionary") 'Late Binding of the Dictionary
Range("T2").Select
While ActiveCell.Value <> ""
Dim key, val
key = ActiveCell.Value: val = ActiveCell.Offset(0, 1).Address
'Add item to VBA Dictionary
If Not dict.Exists(key) Then
dict.Add key, val
End If
ActiveCell.Offset(1, 0).Select
Wend
'Debug.Print dict.Count 'Result: 1
'
'Debug.Print dict.Exists("North")
'For Each key In dict.Keys
' Debug.Print key
'Next key
'
''Print all items
'For Each val In dict.Items
' Debug.Print val
'Next val
'copy format of cells where condition matches
'Dim tempaddress As String
'Range("V2").Select
'tempaddress = Selection.Address
'For Each val In dict.Items
'
'Range(val).Select
'Selection.Copy
'Range(tempaddress).PasteSpecial Paste:=xlPasteFormats
'tempaddress = ActiveCell.Offset(1, 0).Address
'
'Next val
'Application.CutCopyMode = False
Sheets("conditionalformattingvba").Select
Dim workingrange, cell As Range
Range("I2").CurrentRegion.Select
Set workingrange = Selection
Selection.ClearFormats
For Each cell In workingrange
For Each key In dict.Keys
If InStr(1, cell.Value, key, vbTextCompare) > 0 Then
Range(dict(key)).Select
Selection.Copy
cell.PasteSpecial Paste:=xlPasteFormats
Exit For
Else
cell.ClearFormats
End If
Next key
'Debug.Print cell.Address
Next cell
'Dispose of VBA Dictionary
Set dict = Nothing
Application.CutCopyMode = False
End Sub
Sub formatandclear()
Sheets("conditionalformattingvba").Select
Dim workingrange, cell As Range
Range("I2").CurrentRegion.Select
Set workingrange = Selection
'MsgBox (Selection.Rows.Count)
'MsgBox (Selection.Columns.Count)
Dim startrow, startcolumn As Integer
startrow = Range("I2").Row
'MsgBox (startrow)
startcolumn = Range("I2").Column
'MsgBox (startcolumn)
Dim signal As Boolean
signal = False
If (Cells(startrow, startcolumn).Interior.ColorIndex <> 2) And (Cells(startrow, startcolumn).Font.ColorIndex <> 1) Then
For i = 1 To Selection.Rows.Count
For j = 1 To Selection.Columns.Count
Cells(i + (startrow - 1), j + (startcolumn - 1)).Interior.ColorIndex = 2
Cells(i + (startrow - 1), j + (startcolumn - 1)).Font.ColorIndex = 1
Next j
Next i
Else
conditionsuperfinal
End If
End Sub
Sub start_time()
Application.OnTime Now + TimeValue("00:00:10"), "formatandclear"
End Sub
Sub end_time()
Application.OnTime Now + TimeValue("00:00:05"), "formatandclear", False
End Sub
Sub BlinkCell()
'Dim CellToBlink As Range
'Set CellToBlink = Range("H1")
Do While (True)
formatandclear
Application.Wait (Now + TimeValue("0:00:01"))
formatandclear
Application.Wait (Now + TimeValue("0:00:01"))
DoEvents
If Range("D1").Value = 1 Then Exit Do
Loop
End Sub
Tuesday, June 16, 2020
download all pictures and videos from private or public profile of instagram using instaloader and python
pip install instaloader
instaloader -l username -p password profile the.good_life_
where the.good_life_ is the profile name
it will be downloaded in the current directory where you are at in terminal in the folder having similar name as the profile name
Write in a excel cell using CSharp
Create a windows form project,add a com reference named Microsoft Excel 16.0 Object Library
Create a Class named Excel
using System;
using System.Collections.Generic;
using System.Linq;
using System.Text;
using System.Threading.Tasks;
using Microsoft.Office.Interop.Excel;
using _Excel = Microsoft.Office.Interop.Excel;
namespace csharpexcelwritedata
{
class Excel
{
string path = "";
_Application excel = new _Excel.Application();
Workbook wb;
Worksheet ws;
public Excel(string path, int Sheet)
{
this.path = path;
wb = excel.Workbooks.Open(path);
ws = wb.Worksheets[Sheet];
}
public string ReadCell(int i, int j)
{
i++;
j++;
if (ws.Cells[i, j].Value2 != null)
return ws.Cells[i, j].value2;
else
return "";
}
public void WriteToCell(int i,int j,string s)
{
i++;
j++;
ws.Cells[i, j].Value2 = s;
}
public void Save()
{
wb.Save();
}
public void SaveAs(string path)
{
wb.SaveAs(path);
}
public void Close()
{
wb.Close();
}
}
}
Now go to the form code
private void Form1_Load(object sender, EventArgs e)
{
WriteData();
OpenFile();
}
public void WriteData()
{
Excel excel = new Excel(@"C:\Users\allso\source\repos\chsarpexcelpart1\chsarpexcelpart1\Test.xlsx", 1);
excel.WriteToCell(1, 1, "Hello I am writing");
excel.Save();
excel.SaveAs("Test2");
excel.Close();
}
public void OpenFile()
{
Excel excel = new Excel(@"C:\Users\allso\source\repos\chsarpexcelpart1\chsarpexcelpart1\Test.xlsx", 1);
MessageBox.Show(excel.ReadCell(1, 1));
excel.Close();
}
Read a cell from an excel sheet using CSharp
Create a windows form project,add a com reference named Microsoft Excel 16.0 Object Library
Create a Class named Excel
using System;
using System.Collections.Generic;
using System.Linq;
using System.Text;
using System.Threading.Tasks;
using Microsoft.Office.Interop.Excel;
using _Excel = Microsoft.Office.Interop.Excel;
namespace chsarpexcelpart1
{
class Excel
{
string path = "";
_Application excel = new _Excel.Application();
Workbook wb;
Worksheet ws;
public Excel(string path, int Sheet)
{
this.path = path;
wb = excel.Workbooks.Open(path);
ws = wb.Worksheets[Sheet];
}
public string ReadCell(int i, int j)
{
i++;
j++;
if (ws.Cells[i, j].Value2 != null)
return ws.Cells[i, j].value2;
else
return "";
}
public void Close()
{
wb.Close();
}
}
}
Now go to the form code
private void Form1_Load(object sender, EventArgs e)
{
OpenFile();
}
public void OpenFile()
{
Excel excel = new Excel(@"C:\Users\allso\source\repos\chsarpexcelpart1\chsarpexcelpart1\Test.xlsx", 1);
MessageBox.Show(excel.ReadCell(0, 0));
excel.Close();
}
Friday, June 12, 2020
Download playlist with default subtitle using youtube-dl
C:\Windows\system32>youtube-dl --no-check-certificate -cio "C:/Users/allso/Desktop/python_tutorials/%(title)s.%(ext)s" --playlist-start 1 --playlist-end 22 -f best --write-auto-sub https://www.youtube.com/playlist?list=PL998lXKj66MqZ2XoXPelpO9tcgApOzUIE
Subscribe to:
Posts (Atom)