Consulting

Results 1 to 3 of 3

Thread: VBA codes to extract pdf files to excel

  1. #1

    Angry 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 .)

    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
    Last edited by mdmackillop; 05-22-2017 at 01:34 AM. Reason: Code Tags added

  2. #2
    Knowledge Base Approver VBAX Guru
    Joined
    Apr 2012
    Posts
    4,892
    I'd appreciate if you'd use code tags around VBA code.
    And a sample file is always welcome.

  3. #3
    Basically, i'm trying to make this code to work to extract form 6 data from the pdf files from this link mas.gov.sg/Statistics/Insurance-Statistics/Insurance-Company-Returns.aspx. I apologise for the long codes.

    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

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •