Multiple column and String extract VBA

Emanuele

New Member
Joined
Feb 25, 2020
Messages
14
Office Version
  1. 2016
Platform
  1. Windows
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


VBA Code:
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
 

Excel Facts

Create a chart in one keystroke
Select the data and press Alt+F1 to insert a default chart. You can change the default chart to any chart type

Forum statistics

Threads
1,213,528
Messages
6,114,154
Members
448,553
Latest member
slaytonpa

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top