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 .)
Would appreciate the help givenSub 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
Reply With Quote