Excel Forum

Code: Select all

Sub FormatLoanData()

    Dim ws As Worksheet
    Dim outputWs As Worksheet
    Dim lastRow As Long
    Dim currentRow As Long
    Dim outputRow As Long
    Dim currentOfficer As String
    
    ' Set the worksheets
    Set ws = ThisWorkbook.Sheets("RawData") ' Change to your actual data sheet name
    Set outputWs = ThisWorkbook.Sheets.Add
    outputWs.Name = "Output"

    
    outputRow = 2 ' Start output from the second row
    lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row ' Get last row with data
    
    For currentRow = 2 To lastRow ' Assuming first row is header
        ' Check for Credit Officer header
        If InStr(ws.Cells(currentRow, 1), "Credit Officer:") > 0 Then
            currentOfficer = ws.Cells(currentRow, 1).Value ' Store current officer
            ' Skipping the credit officer line
        ElseIf ws.Cells(currentRow, 1).Value <> "" Then
            ' Copy Data to formatted worksheet

            outputWs.Cells(outputRow, 1).Value = ws.Cells(currentRow, 1).Value
            outputWs.Cells(outputRow, 2).Value = ws.Cells(currentRow, 2).Value
            outputWs.Cells(outputRow, 3).Value = ws.Cells(currentRow, 3).Value
            outputWs.Cells(outputRow, 4).Value = ws.Cells(currentRow, 4).Value
            
            outputRow = outputRow + 1 ' Increment output row counter
        End If
    Next currentRow
    
End Sub

Code: Select all

Sub TransformData()
    Dim i As Integer, srAll As Range, tgAll As Range, r As Range
    With Worksheets("RawData")
        Set srAll = .Range("a6", .Range("d" & .Rows.Count).End(xlUp))
    End With
    With Worksheets("required")
        .UsedRange.ClearContents
        .Range("a1").Resize(srAll.Rows.Count, srAll.Columns.Count) _
            .Value = srAll.Value
        Set tgAll = .Range("b2", .Range("b" & .Rows.Count).End(xlUp))
        For Each r In tgAll
            If IsNumeric(VBA.Right(r.Value, 9)) Then
                r.Offset(0, -1).Value = r.Offset(-1, -1).Value + 1
            End If
        Next r
        tgAll.SpecialCells(xlCellTypeBlanks).EntireRow.Delete shift:=xlUp
    End With
End Sub