VBA codes to extract pdf files to excel
Hi,
I am trying to extract certain information from a pdf to file to an excel spreadsheet. This macro that I have seen allows me to download all pdf files from a specific website. However, I have run into some trouble trying to get the macro to work to allow me to extract specific data from the text files. Basically, I would want to extract form 6 data from this website www(dot)mas(dot)gov(dot)sg/Statistics/Insurance-Statistics/Insurance-Company-Returns(dot)aspx (Replace the dot with .)
Code:
Sub clearlinks()
Application.ScreenUpdating = False
Worksheets("Linkslist").Activate
Worksheets("Linkslist").Range(Cells(2, 1), Cells(10000, 10000)).ClearContents
Worksheets("Control").Activate
End Sub
'Idea of solving the blank space in the middle is:
'Get the size of what is being copied
'Do some mathematics, to obtain the size copied, then offset by that amount from the first row of data in form 21
' this should be significantly more consistent
Sub clearform21()
Application.ScreenUpdating = False
Dim template(1, 8)
template(1, 1) = "LSIF_PAR"
template(1, 2) = "LSIF_PAR2"
template(1, 3) = "LSIF_NONPAR"
template(1, 4) = "LSIF_IL"
template(1, 5) = "LOIF_PAR"
template(1, 6) = "LOIF_PAR2"
template(1, 7) = "LOIF_NONPAR"
template(1, 8) = "LOIF_IL"
For i = 1 To 8
Worksheets(template(1, i)).Activate
Worksheets(template(1, i)).Range(Cells(51, 2), Cells(137, 10000)).ClearContents
Next i
Worksheets("Control").Activate
End Sub
Sub clearalldata()
Application.ScreenUpdating = False
Dim template(1, 8)
template(1, 1) = "LSIF_PAR"
template(1, 2) = "LSIF_PAR2"
template(1, 3) = "LSIF_NONPAR"
template(1, 4) = "LSIF_IL"
template(1, 5) = "LOIF_PAR"
template(1, 6) = "LOIF_PAR2"
template(1, 7) = "LOIF_NONPAR"
template(1, 8) = "LOIF_IL"
For i = 1 To 8
Worksheets(template(1, i)).Activate
Worksheets(template(1, i)).Range(Cells(1, 2), Cells(10000, 10000)).ClearContents
Next i
Worksheets("Control").Activate
End Sub
Sub getlinkswithwords()
Application.ScreenUpdating = False
Worksheets("Linkslist").Activate
Dim URL As String, lastrow As Long
Dim XMLHTTP As Object, html As Object
Dim tbl As Object, obj_tbl As Object
Dim TR As Object, td As Object
Dim row As Long, col As Long
lastrow = Range("A" & Rows.Count).End(xlUp).row
' Url is here.
URL = Worksheets("Control").Cells(1, 2).Value
Set XMLHTTP = CreateObject("MSXML2.XMLHTTP")
XMLHTTP.Open "GET", URL, False
XMLHTTP.setRequestHeader "Content-Type", "text/xml"
XMLHTTP.send
Set html = CreateObject("htmlfile")
html.body.innerHTML = XMLHTTP.ResponseText
Set obj_tbl = html.getElementsBytagname("table")
row = 1
col = 1
Dim testing
Dim finale
For Each tbl In obj_tbl
Set TR = tbl.getElementsBytagname("TR")
For Each obj_row In TR
For Each td In obj_row.getElementsBytagname("TD")
Cells(row, col) = td.innertext
For Each Link In obj_row.getElementsBytagname("A")
testing = Link.href
If InStr(testing, "/Statistics/Insurance-Statistics/Insurance-Company-Returns/") Then
finale = Replace(testing, "about:", "www(dot)mas(dot)gov(dot)sg")
Cells(row, 3) = finale
Cells(row, 4) = Replace(finale, "www(dot)mas(dot)gov(dot)sg/Statistics/Insurance-Statistics/Insurance-Company-Returns/", "")
End If
Next
col = col + 1
Next
col = 1 ' reseting the value
row = row + 1
Next
Next
Call webpage
End Sub
Sub DownloadFile()
Dim lastrow
lastrow = Worksheets("Linkslist").Cells(2, 2).End(xlDown).row
' this is for 2015
For i = 2 To lastrow
Dim myURL As String
Dim yy
yy = Application.WorksheetFunction.Match(Worksheets("Control").Cells(3, 2).Value, Worksheets("Linkslist").Range("1:1"), 0)
myURL = Worksheets("Linkslist").Cells(i, yy).Value
If myURL = "" Then
GoTo idiot
End If
Dim WinHttpReq As Object
Set WinHttpReq = CreateObject("Microsoft.XMLHTTP")
WinHttpReq.Open "GET", myURL, False, "username", "password"
WinHttpReq.send
myURL = WinHttpReq.responseBody
If WinHttpReq.Status = 200 Then
Set oStream = CreateObject("ADODB.Stream")
oStream.Open
oStream.Type = 1
oStream.Write WinHttpReq.responseBody
oStream.SaveToFile Worksheets("Control").Cells(2, 2).Value & Worksheets("Linkslist").Cells(i, 2).Value & "-" & Worksheets("Control").Cells(3, 2).Value & ".pdf", 2 ' 1 = no overwrite, 2 = overwrite
oStream.Close
End If
idiot: Next i
End Sub
Sub Run_Extraction()
Application.ScreenUpdating = False
Dim strFile, strPath, strExec, strLine As String
Dim colFiles As New Collection
Dim i, j, k, FileNum, sec, np As Long
Dim nFile, strOut As String
Dim c As Variant
Dim arrCR, arrRP, arrAll As Variant
Dim arrTmp() As Variant
Dim ir, ip, mrow, mcol As Long
Dim cs, ce, cr As String
Dim blTxt, blSet As Boolean
'set directory and file collection
strPath = Worksheets("Control").Cells(2, 2).Value
strFile = Dir(strPath)
'set up
'If Range("flagappend").Value <> True Then
' Call clearoutput
' mrow = Range("outstart").row + 1
'Else
' mrow = Range("outstart").Offset(50000, 0).End(xlUp).row + 1
'End If
'mcol = Range("outstart").Column
'Sheets("Control").Select
'Range("findstart").Select
'load control infomration into array arrTmp
'0 - start text
'1 - end text
'2 - replacements
'3 - boolean in between
'4 - boolean got content
'5 - content found
'Sheets("Control").Select
'Range("findstart").Select
Call expanddown
np = 0
For Each c In Selection
If c.Text <> "" And c.Offset(0, 1).Text <> "" Then
np = np + 1
End If
Next
ReDim arrTmp(np, 5)
np = 0
'fill with pattern information
For Each c In Selection
If c.Text <> "" And c.Offset(0, 1).Text <> "" Then
arrTmp(np, 0) = c.Text
arrTmp(np, 1) = c.Offset(0, 1).Text
arrTmp(np, 2) = c.Offset(0, 2).Text
np = np + 1
End If
Next
np = np - 1
'go to output sheet and populate column names
'Sheets("Output").Select
'For k = 0 To np
' Cells(Range("outstart").row, (3 + k)).Formula = arrTmp(k, 0)
'Next
'get collection of pdf files
While strFile <> ""
If Right(strFile, 4) = ".pdf" Then
colFiles.Add strFile
End If
strFile = Dir
Wend
'loop through pdf files
If colFiles.Count > 0 Then
For i = 1 To colFiles.Count
'display progress
Application.StatusBar = "Processing PDF file " & i & " of " & colFiles.Count & " (" & colFiles(i) & ")"
'get generic name
nFile = Left(colFiles(i), Len(colFiles(i)) - 4)
'convert file to text
strExec = Chr(34) & Chr(34) & strPath & "pdftotext.exe" & Chr(34) & " -layout " & Chr(34) & strPath & colFiles(i) & Chr(34) & Chr(34)
Call Shell("cmd /C " & strExec, vbMinimizedNoFocus)
'wait for text file maximimum 5 seconds
sec = 0
Do Until FileFolderExists(strPath & nFile & ".txt") = True Or sec > 5
Application.Wait (Now + TimeValue("0:00:01"))
sec = sec + 1
Loop
'check if text file is there
blTxt = False
If FileFolderExists(strPath & nFile & ".txt") = True Then
blTxt = True
End If
If blTxt = True Then
'open text file
FileNum = FreeFile
Open strPath & nFile & ".txt" For Input As #FileNum
'loop through text file
Do While Not EOF(FileNum)
Line Input #FileNum, strLine
'set boolean for in set
blSet = False
'test for start text in each pattern
For k = 0 To np
If strLine Like "*" & arrTmp(k, 0) & "*" Then
'check for set and output
If k = 0 Then
strOut = ""
For j = 0 To np
If arrTmp(j, 5) <> "" Then
blSet = True
End If
Next
If blSet = True Then
For j = 0 To np
If arrTmp(j, 5) <> "" Then
strOut = strOut & arrTmp(j, 5) & "^^^"
Else
strOut = strOut & " ^^^"
End If
Next
strOut = Left(strOut, Len(strOut) - 3)
'ouput results
Call Output_Results(CStr(nFile), CStr(strOut), CLng(mrow))
'run replacements and empty array
For j = 0 To np
Call Run_Replacements(CStr(Cells(mrow, (j + 3)).Address), CStr(arrTmp(j, 2)))
arrTmp(j, 3) = False
arrTmp(j, 4) = False
arrTmp(j, 5) = ""
Next
mrow = mrow + 1
End If
End If
arrTmp(k, 5) = Trim(strLine)
'get from the start text
arrTmp(k, 5) = Shorten(CStr(arrTmp(k, 5)), "" & arrTmp(k, 0) & "", False)
'continue if not new line for end text
arrTmp(k, 3) = True
If LCase(Trim(arrTmp(k, 1))) = "[new line]" Then
arrTmp(k, 3) = False
arrTmp(k, 4) = True
End If
'check for end text in same line
If arrTmp(k, 5) Like "*" & arrTmp(k, 1) & "*" Then
arrTmp(k, 5) = Shorten(CStr(arrTmp(k, 5)), "" & arrTmp(k, 1) & "", True)
arrTmp(k, 3) = False
End If
End If
'test for end text
If arrTmp(k, 3) = True And strLine Like "*" & arrTmp(k, 1) & "*" Then
arrTmp(k, 5) = arrTmp(k, 5) & Chr(10) & Shorten(Trim(strLine), "" & arrTmp(k, 1) & "", True)
arrTmp(k, 3) = False
End If
'test if in text gathering and blCont still true and append
If arrTmp(k, 3) = True And arrTmp(k, 5) <> "" And Not strLine Like "*" & arrTmp(k, 0) & "*" Then
arrTmp(k, 5) = arrTmp(k, 5) & Chr(10) & Trim(strLine)
End If
Next
Loop
'output anything leftover
strOut = ""
For j = 0 To np
If arrTmp(j, 5) <> "" Then
blSet = True
End If
Next
If blSet = True Then
For j = 0 To np
If arrTmp(j, 5) <> "" Then
strOut = strOut & arrTmp(j, 5) & "^^^"
Else
strOut = strOut & " ^^^"
End If
Next
strOut = Left(strOut, Len(strOut) - 3)
'ouput results
Call Output_Results(CStr(nFile), CStr(strOut), CLng(mrow))
'run replacements and empty array
For j = 0 To np
Call Run_Replacements(CStr(Cells(mrow, (j + 3)).Address), CStr(arrTmp(j, 2)))
arrTmp(j, 3) = False
arrTmp(j, 4) = False
arrTmp(j, 5) = ""
Next
mrow = mrow + 1
End If
'close text file
Close #FileNum
'delete the text file if not checked to keep
' If Range("flagkeep").Value <> True Then
' Kill strPath & nFile & ".txt"
' End If
End If
Next i
End If
'release memory
If Not IsNull(arrTmp) Then
Erase arrTmp
End If
Application.StatusBar = "Ready"
Application.ScreenUpdating = True
End Sub
Till this point, the codes are used to download and convert the data from pdf to text.
Sub form1()
Application.ScreenUpdating = False
'--------------To copy all company names from linkslist sheet and paste to comparison_creturn sheet-----------------
Dim lastrowlink
lastrowlink = Worksheets("Linkslist").Cells(2, 2).End(xlDown).row
Dim cusheetname
cusheetname = "platform"
Dim template(1, 8)
template(1, 1) = "LSIF_PAR"
template(1, 2) = "LSIF_PAR2"
template(1, 3) = "LSIF_NONPAR"
template(1, 4) = "LSIF_IL"
template(1, 5) = "LOIF_PAR"
template(1, 6) = "LOIF_PAR2"
template(1, 7) = "LOIF_NONPAR"
template(1, 8) = "LOIF_IL"
Dim fundtype(1, 8) As String
'Maybe think about
fundtype(1, 1) = "Life: SIF - Participating"
fundtype(1, 2) = "Life: SIF - Participating 2"
fundtype(1, 3) = "Life: SIF - Non-Participating"
fundtype(1, 4) = "Life: SIF - Investment-Linked"
fundtype(1, 5) = "Life: OIF - Participating"
fundtype(1, 6) = "Life: OIF - Participating 2"
fundtype(1, 7) = "Life: OIF - Non-Participating"
fundtype(1, 8) = "Life: OIF - Investment-Linked"
For f = 1 To 8
Worksheets("Linkslist").Activate
Worksheets("Linkslist").Range(Cells(2, 2), Cells(lastrowlink, 2)).Select
Selection.Copy
Sheets(template(1, f)).Select
Range("B1").Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True
Application.CutCopyMode = False
With Selection
.HorizontalAlignment = xlGeneral
.VerticalAlignment = xlCenter
.WrapText = True
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Next f
'------------------------------------------------------------------Paste ends----------------------------------------------------
'----------------------------------------Importing begins here-----------------------------------
Dim lastrow
lastrow = Worksheets(cusheetname).Cells(60000, 1).End(xlUp).row
Dim filename
'b always starts from 2. Because row 1 in Sheet Linkslist is the headers.
For b = 2 To lastrowlink
filename = Worksheets("Linkslist").Cells(b, 2).Value
Application.StatusBar = "Now processing Form 1 for " & Worksheets("Linkslist").Cells(b, 2).Value & " of (" & b - 1 & "/" & lastrowlink - 1 & ")"
If Dir(Worksheets("Control").Cells(2, 2).Value & filename & "-" & Worksheets("Control").Cells(3, 2).Value & ".txt") = "" Then
Application.StatusBar = "File not found for " & Worksheets("Linkslist").Cells(b, 2).Value
GoTo lol
Else
'loop needs to start here as you need to delete and reimport for different sheets
Worksheets("platform").Activate
ActiveSheet.Range("1:1048576").Select
Selection.Delete Shift:=xlUp
'Need change the parameter here, but you can just observe whats the difference.--------------<<<<<<<<<<<<<<<<<<<<<<<
' So put a loop here over arrays<<<<<<<<<<<--------<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< you kind need to loop over the number of forms.different forms have different para
'Import the textfiles
With ActiveSheet.QueryTables.Add(Connection:= _
"TEXT;" & Worksheets("Control").Cells(2, 2).Value & filename & "-" & Worksheets("Control").Cells(3, 2).Value & ".txt" _
, Destination:=Range("$A$1"))
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.TextFilePromptOnRefresh = False
.TextFilePlatform = 437
.TextFileStartRow = 1
.TextFileParseType = xlFixedWidth
.TextFileTextQualifier = xlTextQualifierDoubleQuote
.TextFileConsecutiveDelimiter = False
.TextFileTabDelimiter = True
.TextFileSemicolonDelimiter = False
.TextFileCommaDelimiter = False
.TextFileSpaceDelimiter = False
.TextFileColumnDataTypes = Array(1, 1, 1, 1)
.TextFileFixedColumnWidths = Array(56, 8, 7) 'difference is only at this row, so you can loop over too.
.TextFileTrailingMinusNumbers = True
.Refresh BackgroundQuery:=False
End With
'-----------------------------------------------------Cleaning the headers-----------------------------------------------
Dim firstsearch
Dim currentsearch
If Len(Worksheets(cusheetname).Range("A1")) <> 0 Then
Rows("1:1").Select
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
End If
Worksheets(cusheetname).Range("A1").Activate
firstsearch = Cells.Find(What:="annual return", After:=ActiveCell, LookIn:=xlValues, _
lookat:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).row
Worksheets(cusheetname).Range("A" & firstsearch + 1).Activate
Do
Cells.Find(What:="annual return", After:=ActiveCell, LookIn:=xlValues, _
lookat:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Activate
currentsearch = ActiveCell.row
For d = 0 To 5
If (IsError(Worksheets(cusheetname).Cells(ActiveCell.Offset(d, 0).row, 2).Value)) Then
Worksheets(cusheetname).Cells(ActiveCell.Offset(d, 0).row, 1).Value = Trim(Worksheets(cusheetname).Cells(ActiveCell.Offset(d, 0).row, 1).Value)
Worksheets(cusheetname).Cells(ActiveCell.Offset(d, 0).row, 2).Value = ""
Worksheets(cusheetname).Cells(ActiveCell.Offset(d, 0).row, 3).Value = ""
Worksheets(cusheetname).Cells(ActiveCell.Offset(d, 0).row, 4).Value = ""
Worksheets(cusheetname).Cells(ActiveCell.Offset(d, 0).row, 5).Value = ""
ElseIf (IsError(Worksheets(cusheetname).Cells(ActiveCell.Offset(d, 0).row, 3).Value)) Then
Worksheets(cusheetname).Cells(ActiveCell.Offset(d, 0).row, 1).Value = Trim(Worksheets(cusheetname).Cells(ActiveCell.Offset(d, 0).row, 1).Value) & Trim(Worksheets(cusheetname).Cells(ActiveCell.Offset(d, 0).row, 2).Value)
Worksheets(cusheetname).Cells(ActiveCell.Offset(d, 0).row, 2).Value = ""
Worksheets(cusheetname).Cells(ActiveCell.Offset(d, 0).row, 3).Value = ""
Worksheets(cusheetname).Cells(ActiveCell.Offset(d, 0).row, 4).Value = ""
Worksheets(cusheetname).Cells(ActiveCell.Offset(d, 0).row, 5).Value = ""
ElseIf (IsError(Worksheets(cusheetname).Cells(ActiveCell.Offset(d, 0).row, 4).Value)) Then
Worksheets(cusheetname).Cells(ActiveCell.Offset(d, 0).row, 1).Value = Trim(Worksheets(cusheetname).Cells(ActiveCell.Offset(d, 0).row, 1).Value) & Trim(Worksheets(cusheetname).Cells(ActiveCell.Offset(d, 0).row, 2).Value) & Trim(Worksheets(cusheetname).Cells(ActiveCell.Offset(d, 0).row, 3).Value)
Worksheets(cusheetname).Cells(ActiveCell.Offset(d, 0).row, 2).Value = ""
Worksheets(cusheetname).Cells(ActiveCell.Offset(d, 0).row, 3).Value = ""
Worksheets(cusheetname).Cells(ActiveCell.Offset(d, 0).row, 4).Value = ""
Worksheets(cusheetname).Cells(ActiveCell.Offset(d, 0).row, 5).Value = ""
ElseIf (IsError(Worksheets(cusheetname).Cells(ActiveCell.Offset(d, 0).row, 5).Value)) Then
Worksheets(cusheetname).Cells(ActiveCell.Offset(d, 0).row, 1).Value = Trim(Worksheets(cusheetname).Cells(ActiveCell.Offset(d, 0).row, 1).Value) & Trim(Worksheets(cusheetname).Cells(ActiveCell.Offset(d, 0).row, 2).Value) & Trim(Worksheets(cusheetname).Cells(ActiveCell.Offset(d, 0).row, 3).Value) & Trim(Worksheets(cusheetname).Cells(ActiveCell.Offset(d, 0).row, 4).Value)
Worksheets(cusheetname).Cells(ActiveCell.Offset(d, 0).row, 2).Value = ""
Worksheets(cusheetname).Cells(ActiveCell.Offset(d, 0).row, 3).Value = ""
Worksheets(cusheetname).Cells(ActiveCell.Offset(d, 0).row, 4).Value = ""
Worksheets(cusheetname).Cells(ActiveCell.Offset(d, 0).row, 5).Value = ""
Else
Worksheets(cusheetname).Cells(ActiveCell.Offset(d, 0).row, 1).Value = Trim(Worksheets(cusheetname).Cells(ActiveCell.Offset(d, 0).row, 1).Value) & Trim(Worksheets(cusheetname).Cells(ActiveCell.Offset(d, 0).row, 2).Value) & Trim(Worksheets(cusheetname).Cells(ActiveCell.Offset(d, 0).row, 3).Value) & Trim(Worksheets(cusheetname).Cells(ActiveCell.Offset(d, 0).row, 4).Value) & Trim(Worksheets(cusheetname).Cells(ActiveCell.Offset(d, 0).row, 5).Value)
Worksheets(cusheetname).Cells(ActiveCell.Offset(d, 0).row, 2).Value = ""
Worksheets(cusheetname).Cells(ActiveCell.Offset(d, 0).row, 3).Value = ""
Worksheets(cusheetname).Cells(ActiveCell.Offset(d, 0).row, 4).Value = ""
Worksheets(cusheetname).Cells(ActiveCell.Offset(d, 0).row, 5).Value = ""
End If
Next d
Loop Until currentsearch = firstsearch
'-------------------------------------------cleaning the amount...------------------------------------------------------
Dim firstsearchamt
Dim currentsearchamt
Dim previoussearchamt
'>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>------------------Another loop here over arrays<<<<<<<<<<<<<<<<<------------------
Worksheets(cusheetname).Range("A1").Activate
firstsearchamt = Cells.Find(What:="ANNUAL RETURN: FORM 1 - FUND", After:=ActiveCell, LookIn:=xlValues, _
lookat:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).row
previoussearchamt = firstsearchamt
Worksheets(cusheetname).Range("A" & firstsearchamt + 1).Activate
Do
Cells.Find(What:="ANNUAL RETURN: FORM 1 - FUND", After:=ActiveCell, LookIn:=xlValues, _
lookat:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Activate
currentsearchamt = ActiveCell.row
If currentsearchamt = firstsearchamt Then
For s = previoussearchamt To previoussearchamt + 60
Worksheets(cusheetname).Cells(s, 4).Value = Worksheets(cusheetname).Cells(s, 4).Value & Worksheets(cusheetname).Cells(s, 5).Value
Worksheets(cusheetname).Cells(s, 5).Value = ""
Next s
Else
For s = previoussearchamt To currentsearchamt
Worksheets(cusheetname).Cells(s, 4).Value = Worksheets(cusheetname).Cells(s, 4).Value & Worksheets(cusheetname).Cells(s, 5).Value
Worksheets(cusheetname).Cells(s, 5).Value = ""
Next s
End If
previoussearchamt = currentsearchamt
Loop Until currentsearchamt = firstsearchamt
End If
'----------------------------------------------------------------------------
'>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> Definitely need anothe rloop here over arrays, here the parameters are harder<<<<<<<<<<<<<<<<
'Now things are getting interesting..... this is to get the rows for all start of Form 1, by searching for its keyword.
Dim rowno()
Dim j
j = 1
Dim finali
Worksheets("platform").Activate
With Worksheets("platform").Range(Cells(1, 1), Cells(lastrow, 1))
Set c = .Find("ANNUAL RETURN: FORM 1 - FUND", LookIn:=xlValues, lookat:=xlPart)
If Not c Is Nothing Then
firstAddress = c.Address
Do
ReDim Preserve rowno(1, j)
rowno(1, j) = c.row
Set c = .FindNext(c)
j = j + 1
Loop While Not c Is Nothing And c.Address <> firstAddress
End If
End With
finali = UBound(rowno, 2)
'This is for within each form 1 search for the keywords
Dim assetsrow
Dim surplusrow
Dim typeoffundrow
For a = 1 To finali
Worksheets("platform").Activate
If a = finali Then
With Worksheets("platform").Range(Cells(rowno(1, a) + 5, 1), Cells(rowno(1, a) + 50, 1))
Set x = .Find("Life", LookIn:=xlValues, lookat:=xlPart)
If x Is Nothing Then GoTo lol
typeoffundrow = x.row
Set y = .Find("assets", LookIn:=xlValues, lookat:=xlWhole)
assetsrow = y.row
Set Z = .Find("surplus", LookIn:=xlValues, lookat:=xlPart)
surplusrow = Z.row
'Copying data from platform and put into individual fundtypes
Worksheets("platform").Range(Cells(assetsrow + 1, 4), Cells(surplusrow, 4)).Copy
For k = 1 To 8
If fundtype(1, k) = Cells(typeoffundrow, 1).Value Then
Worksheets(template(1, k)).Activate
Range("A3").Offset(0, b - 1).Select '<<<<<<<<<<<<<<< here to the array loop over parameter.
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Selection.Style = "Comma"
End If
Next k
End With
'-----------------
Else
'-----------------
With Worksheets("platform").Range(Cells(rowno(1, a) + 5, 1), Cells(rowno(1, a + 1), 1))
Set x = .Find("Life", LookIn:=xlValues, lookat:=xlPart)
If x Is Nothing Then GoTo lol
typeoffundrow = x.row
Set y = .Find("assets", LookIn:=xlValues, lookat:=xlWhole)
assetsrow = y.row
Set Z = .Find("surplus", LookIn:=xlValues, lookat:=xlPart)
surplusrow = Z.row
'Copying data from platform and put into individual fundtypes
'Here also need change god... better individual script easier.----------------Perhaps.. maybe.. easier for individual
Worksheets("platform").Range(Cells(assetsrow + 1, 4), Cells(surplusrow, 4)).Copy
For k = 1 To 8
If fundtype(1, k) = Cells(typeoffundrow, 1).Value Then
Worksheets(template(1, k)).Activate
Range("A3").Offset(0, b - 1).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Selection.Style = "Comma"
End If
Next k
End With
End If
Next a
Application.StatusBar = "Completed" & Worksheets("Linkslist").Cells(b, 2).Value & " of (" & b - 1 & "/" & lastrowlink - 1 & ")"
'----------------------------------------------------------------------------
lol:
Application.CutCopyMode = False
Next b
'>>>>>>>>>>>>>>>>>>>> here you can just do all at once. no need split.
'Giving lines to row 16, 28, 29
For d = 1 To 8
Sheets(template(1, d)).Select
Range("16:16,28:28,29:29").Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
Selection.Borders(xlEdgeLeft).LineStyle = xlNone
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
Selection.Borders(xlEdgeRight).LineStyle = xlNone
Selection.Borders(xlInsideVertical).LineStyle = xlNone
Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
Next d
End Sub
The code above is used to extract data "form 1" into the excel spreadsheet. However, I am unable to extract data for form 6. Would seek help regarding the extraction for form 6. This is my code currently but I have ran into multiple errors
Sub form6()
'For form 6
'Identify part by part of company returns.
Application.ScreenUpdating = False
Worksheets("platform").Activate
'--------------To copy all company names from linkslist sheet and paste to comparison_creturn sheet-----------------
Dim lastrowlink
lastrowlink = Worksheets("Linkslist").Cells(2, 2).End(xlDown).row
Dim cusheetname
cusheetname = "platform"
Dim template(1, 8)
template(1, 1) = "LSIF_PAR"
template(1, 2) = "LSIF_PAR2"
template(1, 3) = "LSIF_NONPAR"
template(1, 4) = "LSIF_IL"
template(1, 5) = "LOIF_PAR"
template(1, 6) = "LOIF_PAR2"
template(1, 7) = "LOIF_NONPAR"
template(1, 8) = "LOIF_IL"
Dim fundtype(1, 8) As String
'Maybe think about
fundtype(1, 1) = "Life: SIF - Participating"
fundtype(1, 2) = "Life: SIF - Participating 2"
fundtype(1, 3) = "Life: SIF - Non-Participating"
fundtype(1, 4) = "Life: SIF - Investment-Linked"
fundtype(1, 5) = "Life: OIF - Participating"
fundtype(1, 6) = "Life: OIF - Participating 2"
fundtype(1, 7) = "Life: OIF - Non-Participating"
fundtype(1, 8) = "Life: OIF - Investment-Linked"
'------------------------------------------------------------------Paste ends----------------------------------------------------
'----------------------------------------Importing begins here-----------------------------------
Dim lastrow
lastrow = Worksheets(cusheetname).Cells(60000, 1).End(xlUp).row
Dim filename
'b always starts from 2. Because row 1 in Sheet Linkslist is the headers.
For b = 2 To lastrowlink
filename = Worksheets("Linkslist").Cells(b, 2).Value
Application.StatusBar = "Now processing Form 6 for " & Worksheets("Linkslist").Cells(b, 2).Value & " of (" & b - 1 & "/" & lastrowlink - 1 & ")"
If Dir(Worksheets("Control").Cells(2, 2).Value & filename & "-" & Worksheets("Control").Cells(3, 2).Value & ".txt") = "" Then
Application.StatusBar = "File not found for " & Worksheets("Linkslist").Cells(b, 2).Value
GoTo lol
Else
Worksheets("platform").Activate
ActiveSheet.Range("1:1048576").Select
Selection.Delete Shift:=xlUp
'Import the textfiles
With ActiveSheet.QueryTables.Add(Connection:= _
"TEXT;" & Worksheets("Control").Cells(2, 2).Value & filename & "-" & Worksheets("Control").Cells(3, 2).Value & ".txt" _
, Destination:=Range("$A$1"))
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.TextFilePromptOnRefresh = False
.TextFilePlatform = 437
.TextFileStartRow = 1
.TextFileParseType = xlFixedWidth
.TextFileTextQualifier = xlTextQualifierDoubleQuote
.TextFileConsecutiveDelimiter = False
.TextFileTabDelimiter = True
.TextFileSemicolonDelimiter = False
.TextFileCommaDelimiter = False
.TextFileSpaceDelimiter = False
.TextFileColumnDataTypes = Array(1, 1, 1, 1, 1)
.TextFileFixedColumnWidths = Array(68, 8, 7, 15)
.TextFileTrailingMinusNumbers = True
.Refresh BackgroundQuery:=False
End With
'-----------------------------------------------------Cleaning the headers-----------------------------------------------
Dim firstsearch
Dim currentsearch
If Len(Worksheets(cusheetname).Range("A1")) <> 0 Then
Rows("1:1").Select
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
End If
Worksheets(cusheetname).Range("A1").Activate
firstsearch = Cells.Find(What:="ANNUAL RETURN", After:=ActiveCell, LookIn:=xlValues, _
lookat:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).row
Worksheets(cusheetname).Range("A" & firstsearch + 1).Activate
Do
Cells.Find(What:="ANNUAL RETURN", After:=ActiveCell, LookIn:=xlValues, _
lookat:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Activate
currentsearch = ActiveCell.row
For d = 0 To 5
If (IsError(Worksheets(cusheetname).Cells(ActiveCell.Offset(d, 0).row, 2).Value)) Then
Worksheets(cusheetname).Cells(ActiveCell.Offset(d, 0).row, 1).Value = Trim(Worksheets(cusheetname).Cells(ActiveCell.Offset(d, 0).row, 1).Value)
Worksheets(cusheetname).Cells(ActiveCell.Offset(d, 0).row, 2).Value = ""
Worksheets(cusheetname).Cells(ActiveCell.Offset(d, 0).row, 3).Value = ""
Worksheets(cusheetname).Cells(ActiveCell.Offset(d, 0).row, 4).Value = ""
Worksheets(cusheetname).Cells(ActiveCell.Offset(d, 0).row, 5).Value = ""
ElseIf (IsError(Worksheets(cusheetname).Cells(ActiveCell.Offset(d, 0).row, 3).Value)) Then
Worksheets(cusheetname).Cells(ActiveCell.Offset(d, 0).row, 1).Value = Trim(Worksheets(cusheetname).Cells(ActiveCell.Offset(d, 0).row, 1).Value) & Trim(Worksheets(cusheetname).Cells(ActiveCell.Offset(d, 0).row, 2).Value)
Worksheets(cusheetname).Cells(ActiveCell.Offset(d, 0).row, 2).Value = ""
Worksheets(cusheetname).Cells(ActiveCell.Offset(d, 0).row, 3).Value = ""
Worksheets(cusheetname).Cells(ActiveCell.Offset(d, 0).row, 4).Value = ""
Worksheets(cusheetname).Cells(ActiveCell.Offset(d, 0).row, 5).Value = ""
ElseIf (IsError(Worksheets(cusheetname).Cells(ActiveCell.Offset(d, 0).row, 4).Value)) Then
Worksheets(cusheetname).Cells(ActiveCell.Offset(d, 0).row, 1).Value = Trim(Worksheets(cusheetname).Cells(ActiveCell.Offset(d, 0).row, 1).Value) & Trim(Worksheets(cusheetname).Cells(ActiveCell.Offset(d, 0).row, 2).Value) & Trim(Worksheets(cusheetname).Cells(ActiveCell.Offset(d, 0).row, 3).Value)
Worksheets(cusheetname).Cells(ActiveCell.Offset(d, 0).row, 2).Value = ""
Worksheets(cusheetname).Cells(ActiveCell.Offset(d, 0).row, 3).Value = ""
Worksheets(cusheetname).Cells(ActiveCell.Offset(d, 0).row, 4).Value = ""
Worksheets(cusheetname).Cells(ActiveCell.Offset(d, 0).row, 5).Value = ""
ElseIf (IsError(Worksheets(cusheetname).Cells(ActiveCell.Offset(d, 0).row, 5).Value)) Then
Worksheets(cusheetname).Cells(ActiveCell.Offset(d, 0).row, 1).Value = Trim(Worksheets(cusheetname).Cells(ActiveCell.Offset(d, 0).row, 1).Value) & Trim(Worksheets(cusheetname).Cells(ActiveCell.Offset(d, 0).row, 2).Value) & Trim(Worksheets(cusheetname).Cells(ActiveCell.Offset(d, 0).row, 3).Value) & Trim(Worksheets(cusheetname).Cells(ActiveCell.Offset(d, 0).row, 4).Value)
Worksheets(cusheetname).Cells(ActiveCell.Offset(d, 0).row, 2).Value = ""
Worksheets(cusheetname).Cells(ActiveCell.Offset(d, 0).row, 3).Value = ""
Worksheets(cusheetname).Cells(ActiveCell.Offset(d, 0).row, 4).Value = ""
Worksheets(cusheetname).Cells(ActiveCell.Offset(d, 0).row, 5).Value = ""
Else
Worksheets(cusheetname).Cells(ActiveCell.Offset(d, 0).row, 1).Value = Trim(Worksheets(cusheetname).Cells(ActiveCell.Offset(d, 0).row, 1).Value) & Trim(Worksheets(cusheetname).Cells(ActiveCell.Offset(d, 0).row, 2).Value) & Trim(Worksheets(cusheetname).Cells(ActiveCell.Offset(d, 0).row, 3).Value) & Trim(Worksheets(cusheetname).Cells(ActiveCell.Offset(d, 0).row, 4).Value) & Trim(Worksheets(cusheetname).Cells(ActiveCell.Offset(d, 0).row, 5).Value)
Worksheets(cusheetname).Cells(ActiveCell.Offset(d, 0).row, 2).Value = ""
Worksheets(cusheetname).Cells(ActiveCell.Offset(d, 0).row, 3).Value = ""
Worksheets(cusheetname).Cells(ActiveCell.Offset(d, 0).row, 4).Value = ""
Worksheets(cusheetname).Cells(ActiveCell.Offset(d, 0).row, 5).Value = ""
End If
Next d
Loop Until currentsearch = firstsearch
Dim firstsearchamt
Dim currentsearchamt
Dim previoussearchamt
Worksheets(cusheetname).Range("A1").Activate
firstsearchamt = Cells.Find(What:="ANNUAL RETURN", After:=ActiveCell, LookIn:=xlValues, _
lookat:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).row
previoussearchamt = firstsearchamt
Worksheets(cusheetname).Range("A" & firstsearchamt + 1).Activate
Do
Cells.Find(What:="ANNUAL RETURN", After:=ActiveCell, LookIn:=xlValues, _
lookat:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Activate
currentsearchamt = ActiveCell.row
If currentsearchamt = firstsearchamt Then
For s = previoussearchamt To previoussearchamt + 60
Worksheets(cusheetname).Cells(s, 4).Value = Worksheets(cusheetname).Cells(s, 4).Value & Worksheets(cusheetname).Cells(s, 5).Value
Worksheets(cusheetname).Cells(s, 5).Value = ""
Next s
Else
For s = previoussearchamt To currentsearchamt
Worksheets(cusheetname).Cells(s, 4).Value = Worksheets(cusheetname).Cells(s, 4).Value & Worksheets(cusheetname).Cells(s, 5).Value
Worksheets(cusheetname).Cells(s, 5).Value = ""
Next s
End If
previoussearchamt = currentsearchamt
Loop Until currentsearchamt = firstsearchamt
End If
'----------------------------------------------------------------------------
'Now things are getting interesting..... this is to get the rows for all start of Form 1, by searching for its keyword.
Dim rowno()
Dim j
j = 1
Dim finali
Worksheets("platform").Activate
With Worksheets("platform").Range(Cells(1, 1), Cells(lastrow, 1))
Set c = .Find("ANNUAL RETURN", LookIn:=xlValues, lookat:=xlPart)
If Not c Is Nothing Then
firstAddress = c.Address
Do
ReDim Preserve rowno(1, j)
rowno(1, j) = c.row
Debug.Print rowno(1, j)
Set c = .FindNext(c)
j = j + 1
Loop While Not c Is Nothing And c.Address <> firstAddress
End If
End With
'If this step error means they did not manage to find anything on top.
finali = UBound(rowno, 2)
Debug.Print finali
'This is for within each form 1 search for the keywords
Dim assetsrow
Dim surplusrow
Dim typeoffundrow
For a = 1 To finali
Worksheets("platform").Activate
If a = finali Then
With Worksheets("platform").Range(Cells(rowno(1, a) + 5, 1), Cells(rowno(1, a) + 50, 1))
Set x = .Find("Life", LookIn:=xlValues, lookat:=xlPart)
If x Is Nothing Then GoTo lol
typeoffundrow = x.row
Set y = .Find("gross premiums", LookIn:=xlValues, lookat:=xlPart)
assetsrow = y.row
Set Z = .Find("net income", LookIn:=xlValues, lookat:=xlPart)
surplusrow = Z.row
'Copying data from platform and put into individual fundtypes
Worksheets("platform").Range(Cells(assetsrow, 4), Cells(surplusrow, 4)).Copy
For k = 1 To 8
If fundtype(1, k) = Cells(typeoffundrow, 1).Value Then
Worksheets(template(1, k)).Activate
Range("A33").Offset(0, b - 1).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Selection.Style = "Comma"
End If
Next k
End With
'-----------------
Else
'-----------------
With Worksheets("platform").Range(Cells(rowno(1, a) + 5, 1), Cells(rowno(1, a + 1), 1))
Set x = .Find("Life", LookIn:=xlValues, lookat:=xlPart)
If x Is Nothing Then GoTo lol
typeoffundrow = x.row
Set y = .Find("gross premiums", LookIn:=xlValues, lookat:=xlPart)
assetsrow = y.row
Set Z = .Find("net income", LookIn:=xlValues, lookat:=xlPart)
surplusrow = Z.row
'Copying data from platform and put into individual fundtypes
Worksheets("platform").Range(Cells(assetsrow, 4), Cells(surplusrow, 4)).Copy
For k = 1 To 8
If fundtype(1, k) = Cells(typeoffundrow, 1).Value Then
Worksheets(template(1, k)).Activate
Range("A33").Offset(0, b - 1).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Selection.Style = "Comma"
End If
Next k
End With
End If
Next a
Application.StatusBar = "Completed" & Worksheets("Linkslist").Cells(b, 2).Value & " of (" & b - 1 & "/" & lastrowlink - 1 & ")"
'----------------------------------------------------------------------------
lol:
Application.CutCopyMode = False
Next b
'Giving lines to row 38,47,48
For d = 1 To 8
Sheets(template(1, d)).Select
Range("38:38,47:47,48:48").Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
Selection.Borders(xlEdgeLeft).LineStyle = xlNone
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
Selection.Borders(xlEdgeRight).LineStyle = xlNone
Selection.Borders(xlInsideVertical).LineStyle = xlNone
Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
Next d
End Sub
Would appreciate the help given:yes
