Code to post selected headings with selected data to another sheet in fixed order

[RAJESH1960]

Hello guys

In the workbook shared in the link, PORTAL is a merged sheet with lot of columns not required. The headings are in the same order always. I copied only the required Headings of sheet Portal to Edited Portal, in the order as shown in Edited Portal which are entered manually with a few extra headings in some columns . I have copied the bold fonts rows from each column in Portal to Edited Portal in regular fonts. I removed the “-Total” from the invoice number in Edited Portal. The columns with the amount values are converted to number format with 2 decimal places. The invoice date is changed to dd-mm-yyyy format. And finally, the columns Line and As Per are filled from 2nd row to the last cell with value, as shown. This drill is the same in all cases and it takes hours to do this. So, I thought a code will definitely help me to do the above in seconds.
Loading Google Sheets

 

[RAJESH1960]

I know that the original dates are not in the exact date format, but I have found this way to correct it as in the code I have shared. You can change the range and include it your code wherever necessary.

 

[johnnyL]

Ok. How about:

Sub Test3()
'
    Dim DestinationSheetExists      As Boolean
    Dim OutputArrayRow              As Long, SourceArrayRow             As Long
    Dim SourceDataStartRow          As Long, SourceLastRow              As Long
    Dim DestinationSheet            As String
    Dim SourceDataLastWantedColumn  As String, SourceDataStartColumn    As String
    Dim OutputArray                 As Variant, SourceArray             As Variant
    Dim wsDestination               As Worksheet, wsSource              As Worksheet
'
    DestinationSheet = "Edited Portal"                          ' <--- Set this to the name of the sheet to store the shortened Portal data into
        Set wsSource = Sheets("PORTAL")                         ' <--- Set this to the Portal sheet that you want data from
'
    SourceDataLastWantedColumn = "M"                            ' <--- Set this to the last column of wanted data on the source sheet
    SourceDataStartColumn = "A"                                 ' <--- Set this to the starting column of wanted data on the source sheet
    SourceDataStartRow = 7                                      ' <--- Set this to the starting row of data on the source sheet
'
    On Error Resume Next                                        '   Bypass error generated in next line if sheet does not exist
    Set wsDestination = Sheets(DestinationSheet)                '   Assign DestinationSheet to wsDestination
    On Error GoTo 0                                             '   Turn Excel error handling back on
'
    If Not wsDestination Is Nothing Then DestinationSheetExists = True  '   Check to see if the DestinationSheet exists
'
' Create DestinationSheet if it doesn't exist
    If DestinationSheetExists = False Then                      '   If DestinationSheet does not exist then ...
        Sheets.Add(After:=wsSource).Name = DestinationSheet     '       Create the DestinationSheet after the Source sheet
        Set wsDestination = Sheets(DestinationSheet)            '       Assign the DestinationSheet to wsDestination
    End If
'
'---------------------------------------------------------------
'
' Write all header values into the DestinationSheet
    wsDestination.Range("A1:M1").Value = Array("Line", "As Per", "GSTIN of supplier", _
            "Trade/Legal name of the Supplier", "Invoice number", "Invoice Date", _
            "Integrated Tax", "Central Tax", "State/UT", "Remarks", "Invoice Value", _
            "Taxable Value", "Data from")                                               ' Write header row to DestinationSheet
'
    SourceLastRow = wsSource.Range("A" & Rows.Count).End(xlUp).Row  ' Get last row used in column A of the source sheeet
'
    SourceArray = wsSource.Range(SourceDataStartColumn & SourceDataStartRow & _
            ":" & SourceDataLastWantedColumn & SourceLastRow)   ' Load all needed data from from source sheet to 2D 1 based SourceArray RC
'
''Debug.Print UBound(SourceArray, 1)  ' 307
''Debug.Print SourceArray(307, 3)
'
    ReDim OutputArray(1 To UBound(SourceArray, 1), 1 To UBound(SourceArray, 2))        '   Establish # of rows/columns in 2D 1 based OutputArray
    OutputArrayRow = 0                                          ' Initialize OutputArrayRow
'
    For SourceArrayRow = 1 To UBound(SourceArray, 1)                                    ' Loop through all rows of SourceArray
        If Right$(Application.Trim(SourceArray(SourceArrayRow, 3)), 6) = "-Total" Then  '   If a total cell is found in the array then ...
            OutputArrayRow = OutputArrayRow + 1                                         '       Increment OutputArrayRow
'
            OutputArray(OutputArrayRow, 1) = OutputArrayRow                     ' Row #
            OutputArray(OutputArrayRow, 2) = "PORTAL"
'
            OutputArray(OutputArrayRow, 3) = SourceArray(SourceArrayRow, 1)     ' GSTIN
            OutputArray(OutputArrayRow, 4) = SourceArray(SourceArrayRow, 2)     ' Name of supplier
'
            OutputArray(OutputArrayRow, 5) = Left$(SourceArray(SourceArrayRow, 3), Len(SourceArray(SourceArrayRow, 3)) - 6) ' Invoice #
            OutputArray(OutputArrayRow, 6) = SourceArray(SourceArrayRow, 5)     ' Invoice Date
'
            OutputArray(OutputArrayRow, 7) = SourceArray(SourceArrayRow, 11)    ' Integrated Tax
            OutputArray(OutputArrayRow, 8) = SourceArray(SourceArrayRow, 12)    ' Central Tax
            OutputArray(OutputArrayRow, 9) = SourceArray(SourceArrayRow, 13)    ' State/UT Tax
'
            OutputArray(OutputArrayRow, 11) = SourceArray(SourceArrayRow, 6)    ' Invoice value
            OutputArray(OutputArrayRow, 12) = SourceArray(SourceArrayRow, 10)   ' Taxable value
            OutputArray(OutputArrayRow, 13) = "PORTAL"
        End If
    Next
'
    wsDestination.Columns("F:F").NumberFormat = "@"                             ' Set column to text format to prevent excel changing dates
    wsDestination.Range("A2").Resize(UBound(OutputArray, 1), UBound(OutputArray, 2)) = OutputArray  ' Display results to DestinationSheet
'
    wsDestination.Range("G:I", "K:L").NumberFormat = "0.00"                     ' Set columns to numeric with 2 decimal places
'
    wsDestination.Range("F:F").NumberFormat = "dd-mm-yyyy"                      ' Format the date the way we want it to appear
    wsDestination.Columns("F:F").TextToColumns Destination:=Range("F1"), _
            DataType:=xlDelimited, FieldInfo:=Array(1, 4)                       ' Convert text to numeric
'
    wsDestination.UsedRange.EntireColumn.AutoFit                                ' Autofit all of the columns on the DestinationSheet
End Sub

 

[RAJESH1960]

Ok. How about:

Sub Test3()
'
    Dim DestinationSheetExists      As Boolean
    Dim OutputArrayRow              As Long, SourceArrayRow             As Long
    Dim SourceDataStartRow          As Long, SourceLastRow              As Long
    Dim DestinationSheet            As String
    Dim SourceDataLastWantedColumn  As String, SourceDataStartColumn    As String
    Dim OutputArray                 As Variant, SourceArray             As Variant
    Dim wsDestination               As Worksheet, wsSource              As Worksheet
'
    DestinationSheet = "Edited Portal"                          ' <--- Set this to the name of the sheet to store the shortened Portal data into
        Set wsSource = Sheets("PORTAL")                         ' <--- Set this to the Portal sheet that you want data from
'
    SourceDataLastWantedColumn = "M"                            ' <--- Set this to the last column of wanted data on the source sheet
    SourceDataStartColumn = "A"                                 ' <--- Set this to the starting column of wanted data on the source sheet
    SourceDataStartRow = 7                                      ' <--- Set this to the starting row of data on the source sheet
'
    On Error Resume Next                                        '   Bypass error generated in next line if sheet does not exist
    Set wsDestination = Sheets(DestinationSheet)                '   Assign DestinationSheet to wsDestination
    On Error GoTo 0                                             '   Turn Excel error handling back on
'
    If Not wsDestination Is Nothing Then DestinationSheetExists = True  '   Check to see if the DestinationSheet exists
'
' Create DestinationSheet if it doesn't exist
    If DestinationSheetExists = False Then                      '   If DestinationSheet does not exist then ...
        Sheets.Add(After:=wsSource).Name = DestinationSheet     '       Create the DestinationSheet after the Source sheet
        Set wsDestination = Sheets(DestinationSheet)            '       Assign the DestinationSheet to wsDestination
    End If
'
'---------------------------------------------------------------
'
' Write all header values into the DestinationSheet
    wsDestination.Range("A1:M1").Value = Array("Line", "As Per", "GSTIN of supplier", _
            "Trade/Legal name of the Supplier", "Invoice number", "Invoice Date", _
            "Integrated Tax", "Central Tax", "State/UT", "Remarks", "Invoice Value", _
            "Taxable Value", "Data from")                                               ' Write header row to DestinationSheet
'
    SourceLastRow = wsSource.Range("A" & Rows.Count).End(xlUp).Row  ' Get last row used in column A of the source sheeet
'
    SourceArray = wsSource.Range(SourceDataStartColumn & SourceDataStartRow & _
            ":" & SourceDataLastWantedColumn & SourceLastRow)   ' Load all needed data from from source sheet to 2D 1 based SourceArray RC
'
''Debug.Print UBound(SourceArray, 1)  ' 307
''Debug.Print SourceArray(307, 3)
'
    ReDim OutputArray(1 To UBound(SourceArray, 1), 1 To UBound(SourceArray, 2))        '   Establish # of rows/columns in 2D 1 based OutputArray
    OutputArrayRow = 0                                          ' Initialize OutputArrayRow
'
    For SourceArrayRow = 1 To UBound(SourceArray, 1)                                    ' Loop through all rows of SourceArray
        If Right$(Application.Trim(SourceArray(SourceArrayRow, 3)), 6) = "-Total" Then  '   If a total cell is found in the array then ...
            OutputArrayRow = OutputArrayRow + 1                                         '       Increment OutputArrayRow
'
            OutputArray(OutputArrayRow, 1) = OutputArrayRow                     ' Row #
            OutputArray(OutputArrayRow, 2) = "PORTAL"
'
            OutputArray(OutputArrayRow, 3) = SourceArray(SourceArrayRow, 1)     ' GSTIN
            OutputArray(OutputArrayRow, 4) = SourceArray(SourceArrayRow, 2)     ' Name of supplier
'
            OutputArray(OutputArrayRow, 5) = Left$(SourceArray(SourceArrayRow, 3), Len(SourceArray(SourceArrayRow, 3)) - 6) ' Invoice #
            OutputArray(OutputArrayRow, 6) = SourceArray(SourceArrayRow, 5)     ' Invoice Date
'
            OutputArray(OutputArrayRow, 7) = SourceArray(SourceArrayRow, 11)    ' Integrated Tax
            OutputArray(OutputArrayRow, 8) = SourceArray(SourceArrayRow, 12)    ' Central Tax
            OutputArray(OutputArrayRow, 9) = SourceArray(SourceArrayRow, 13)    ' State/UT Tax
'
            OutputArray(OutputArrayRow, 11) = SourceArray(SourceArrayRow, 6)    ' Invoice value
            OutputArray(OutputArrayRow, 12) = SourceArray(SourceArrayRow, 10)   ' Taxable value
            OutputArray(OutputArrayRow, 13) = "PORTAL"
        End If
    Next
'
    wsDestination.Columns("F:F").NumberFormat = "@"                             ' Set column to text format to prevent excel changing dates
    wsDestination.Range("A2").Resize(UBound(OutputArray, 1), UBound(OutputArray, 2)) = OutputArray  ' Display results to DestinationSheet
'
    wsDestination.Range("G:I", "K:L").NumberFormat = "0.00"                     ' Set columns to numeric with 2 decimal places
'
    wsDestination.Range("F:F").NumberFormat = "dd-mm-yyyy"                      ' Format the date the way we want it to appear
    wsDestination.Columns("F:F").TextToColumns Destination:=Range("F1"), _
            DataType:=xlDelimited, FieldInfo:=Array(1, 4)                       ' Convert text to numeric
'
    wsDestination.UsedRange.EntireColumn.AutoFit                                ' Autofit all of the columns on the DestinationSheet
End Sub

Perfect!!! Thanks JohnnyL. See you soon. With your comments to each line of code, I don't think I will have any problems if there are any changes and I need to edit. Thank you once again.?

 

[johnnyL]

Glad to help @RAJESH1960.