Multiple column and String extract VBA

[Emanuele]

Hi guys, I would like to know if there is a way to add more than 1 adjacent column for the presented code that Fluff helped me to modify in this Post
Furthermore it's possible to apply a string extract (for example, extract the first 4 and the last 4 characters and put them in different column)?
Thank you

Function LastRow(sh As Worksheet)
    On Error Resume Next
    LastRow = sh.Cells.Find(What:="*", _
                            After:=sh.Range("A1"), _
                            Lookat:=xlPart, _
                            LookIn:=xlFormulas, _
                            SearchOrder:=xlByRows, _
                            SearchDirection:=xlPrevious, _
                            MatchCase:=False).Row
    On Error GoTo 0
End Function
Function LastCol(sh As Worksheet)
    On Error Resume Next
    LastCol = sh.Cells.Find(What:="*", _
                            After:=sh.Range("A1"), _
                            Lookat:=xlPart, _
                            LookIn:=xlFormulas, _
                            SearchOrder:=xlByColumns, _
                            SearchDirection:=xlPrevious, _
                            MatchCase:=False).Column
    On Error GoTo 0
End Function
Sub AppendDataAfterLastColumn()
    Dim sh As Worksheet
    Dim DestSh As Worksheet
    Dim Last As Long
    Dim Copy1 As Range
    Dim Copy2 As Range
    Dim Copy3 As Range
    Dim Copy4 As Range

    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With

    ' Delete the summary worksheet if it exists.
    Application.DisplayAlerts = False
    On Error Resume Next
    ActiveWorkbook.Worksheets("Statistics").Delete
    On Error GoTo 0
    Application.DisplayAlerts = True
    ' Add a worksheet with the name ""
    Set DestSh = ActiveWorkbook.Worksheets.Add
    DestSh.Name = "Statistics"
    ' Find the last column with data on the summary
    ' worksheet.
    Last = LastCol(DestSh)
    ' Loop through all worksheets and copy the data to the
     'summary worksheet.
    For Each sh In ActiveWorkbook.Worksheets
        If sh.Name <> DestSh.Name Then
            ' Fill in the columns that you want to copy.
            Set Copy1 = sh.Range("C8:AZ8")
            'Set Copy2 = sh.Range("C10:AZ10") 'second possible column'
           'Set Copy3 = sh.Range("C11:AZ11") 'extract the first 4 characters and put in a column then the last 4 characters and put in adjacent column


           
            ' aggiungere le altre righe e una intestazione, verificare la possibilità di fare grafici in automatico e verificare se è possibile evitare di eliminare il file ogni volta
       
            ' This statement copies and transpose the valuse
            With Copy1
            .Value
                DestSh.Cells(Rows.Count, Last + 1).End(xlUp).Offset(1).Resize(.Columns.Count).Value = Application.Transpose(.Value)
            End With
           ' With Copy2
           '     DestSh.Cells(Rows.Count, Last + 1).End(xlUp).Offset(1).Resize(.Columns.Count).Value = Application.Transpose(.Value)
           'End With
           ' With Copy3
           '     DestSh.Cells(Rows.Count, Last + 1).End(xlUp).Offset(1).Resize(.Columns.Count).Value = Application.Transpose(.Value)
           'End With
        End If
    Next
   
ExitTheSub:

    Application.Goto DestSh.Cells(1)

    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With
End Sub

 

[Emanuele]

Bump up

 

[Emanuele]

Bump up

 

[Emanuele]

Bump up