Extracting Four Specific Data for each Row. Complex and Disorganized Raw Data.

[Paul_Hossler]

Try something like this

I think I understood. Results are on "Sheet1-Extract' in the attachment

Option Explicit
Sub Extract()
    Dim ws1 As Worksheet, ws2 As Worksheet
    Dim rReport As Range, rReportEnd As Range, rReportRow As Range
    Dim sReportDate As String, InfoA As String, InfoG As String, InfoH As String
    Dim iRow As Long, iExtract As Long
    
    
    'setup
    Application.ScreenUpdating = False
    Set ws1 = ActiveSheet
    
    Set rReportEnd = ws1.Cells(ws1.Rows.Count, 1).End(xlUp)
    Set rReport = Range(ws1.Cells(1, 1), rReportEnd).Resize(, 9)
    
    iExtract = 1
    
    'delete output sheet
    On Error Resume Next
    Application.DisplayAlerts = False
    Worksheets(ws1.Name & "-Extract").Delete
    Application.DisplayAlerts = True
    On Error GoTo 0
    'add extract sheet
    Worksheets.Add(, ws1).Name = ws1.Name & "-Extract"
    Set ws2 = Worksheets(ws1.Name & "-Extract")
    
    
    'go down report
    For Each rReportRow In rReport.Rows
        With rReportRow
            
            'Report Date: 03-Dec-18
            If Left(.Cells(1).Value, 11) = "Report Date" Then
                sReportDate = Right(.Cells(1).Value, 9)
            
            ElseIf IsNumeric(.Cells(1).Value) Then
                If Len(Format(.Cells(1).Value)) = 15 Then
                    InfoA = Format(.Cells(1).Value)
                    
                    'InfoG and InfoH in 7 and 8 maybe
                    If Len(.Cells(6).Value) = 0 Then
                        If Format(.Cells(7).Value) Like "2020######" Or .Cells(7).Value Like "[A-Z][A-Z]#####" Then
                            InfoG = .Cells(7).Value
                        End If
                        If Format(.Cells(8).Value) Like "2020######" Or .Cells(8).Value Like "[A-Z][A-Z]#####" Then
                            InfoH = .Cells(8).Value
                        End If
                        
                    'InfoG and InfoH in 6 and 8 maybe
                    ElseIf Len(.Cells(7).Value) = 0 Then
                        If Format(.Cells(6).Value) Like "2020######" Or .Cells(6).Value Like "[A-Z][A-Z]#####" Then
                            InfoG = .Cells(6).Value
                        End If
                        If Format(.Cells(8).Value) Like "2020######" Or .Cells(8).Value Like "[A-Z][A-Z]#####" Then
                            InfoH = .Cells(8).Value
                        End If
                        
                    'InfoG and InfoH in 6 and 7 maybe
                    ElseIf Len(.Cells(8).Value) = 0 Then
                        If Format(.Cells(6).Value) Like "2020######" Or .Cells(6).Value Like "[A-Z][A-Z]#####" Then
                            InfoG = .Cells(6).Value
                        End If
                        If Format(.Cells(7).Value) Like "2020######" Or .Cells(7).Value Like "[A-Z][A-Z]#####" Then
                            InfoH = .Cells(7).Value
                        End If
                    End If
            
                    'write to extract sheet
                    If Len(InfoG) > 0 Then
                        ws2.Cells(iExtract, 1).Value = InfoG
                        ws2.Cells(iExtract, 2).Value = sReportDate
                        ws2.Cells(iExtract, 3).Value = "'" & InfoA
                        ws2.Cells(iExtract, 4).Value = "Malaysia"
                        iExtract = iExtract + 1
                    End If
                    
                    If Len(InfoH) > 0 Then
                        ws2.Cells(iExtract, 1).Value = InfoH
                        ws2.Cells(iExtract, 2).Value = sReportDate
                        ws2.Cells(iExtract, 3).Value = "'" & InfoA
                        ws2.Cells(iExtract, 4).Value = "Malaysia"
                        iExtract = iExtract + 1
                    End If
                End If
            
            End If
        
            InfoA = vbNullString
            InfoG = vbNullString
            InfoH = vbNullString
        
        End With
    
    Next
    
    'format and cleanup
    ws2.Cells(1, 1).CurrentRegion.EntireColumn.AutoFit
    Application.ScreenUpdating = True
    MsgBox "Done"
End Sub