Creating a loop to copy a result row from number of worksheets to a new worksheet

Question

Good afternoon,

I am trying to read number of csv files and load them in a new workbook. Then created codes to find the largest number from each column (i.e. maximum value) and pasted in the bottom of each column. I have completed up to the stage of calcualting the largest value and pasting in the lastrow with the help of this forum.

Now I am trying to transfer them in a new worksheet that I created and named as result with my code. With previous suggestions I have figured out how to paste a specific range from one column to another worksheet with the following example:

Sub OneCell()
   Sheets("Result").Range("E3:V3").Value = Sheets("HP5_1gs_120_2012.plt").Range("E3:V3").Value
End Sub

But not sure how can I loop this with my existing codes to read the last row where my max values are (highlighted in yellow in figure 1) and paste to the result sheet with the header from column E to the last available column and the rowname as the worksheet name. My data structure will be same for each worksheet for each run. And my start column is always column "E" but the end column (i.e. the last column) can be different for each run. THis is what I am getting really confused of how do I loop thorugh this. So for an example a simple dataset like below (Figure 1):

I am trying to achieve this (figure 2):

my main codes are as below:

Private Sub FilePath_Button_Click()
get_folder
End Sub

Private Sub Run_Button_Click()
load_file
End Sub

Public Sub get_folder()

Dim FolderName As String
With Application.FileDialog(msoFileDialogFolderPicker)
  .AllowMultiSelect = False
  .Show
  On Error Resume Next
  FolderName = .SelectedItems(1)
  Err.Clear
  On Error GoTo 0
End With
TextBox1.Text = FolderName
End Sub

Sub load_file()
Dim strFile As String
Dim ws As Worksheet
Dim test As String

Dim wb As Workbook

test = TextBox1.Text

strFile = Dir(Me.TextBox1.Text & "\*.csv")

       Set wb = Workbooks.Add
        'added workbook becomes the activeworkbook
       With wb
       Do While Len(strFile) > 0

        Set ws = ActiveWorkbook.Sheets.Add
        ws.Name = strFile

With ws.QueryTables.Add(Connection:= _
     "TEXT;" & test & "\" & strFile, Destination:=Range("$A$1"))
    .Name = strFile
    .FieldNames = True
    .RowNumbers = False
    .FillAdjacentFormulas = False
    .PreserveFormatting = True
    .RefreshOnFileOpen = False
    .RefreshStyle = xlInsertDeleteCells
    .SavePassword = False
    .SaveData = True
    .AdjustColumnWidth = True
    .RefreshPeriod = 0
    .TextFilePromptOnRefresh = False
    .TextFilePlatform = 437
    .TextFileStartRow = 1
    .TextFileParseType = xlDelimited
    .TextFileTextQualifier = xlTextQualifierDoubleQuote
    .TextFileConsecutiveDelimiter = False
    .TextFileTabDelimiter = False
    .TextFileSemicolonDelimiter = False
    .TextFileCommaDelimiter = True
    .TextFileSpaceDelimiter = False

    .TextFileTrailingMinusNumbers = True
    .Refresh BackgroundQuery:=False
End With
strFile = Dir
Loop
End With

Application.DisplayAlerts = False
Worksheets("Sheet1").Delete
Worksheets("Sheet2").Delete
Worksheets("Sheet3").Delete
Application.DisplayAlerts = True

 Dim ws1 As Worksheet
 Dim ColNo As Long, lc As Long
 Dim lastrow As Long

    For Each ws1 In ActiveWorkbook.Worksheets
       lastrow = Range("A1").End(xlDown).Row
        lc = ws1.Cells(1, Columns.Count).End(xlToLeft).Column
         For ColNo = 5 To lc
           ws1.Cells(lastrow + 2, ColNo).Formula = "=MAX(" & Split(Cells(, ColNo).Address, "$")(1) & "1:" & Split(Cells(, ColNo).Address, "$")(1) & lastrow & ")"
        Next ColNo
    Next ws1

Dim ws2 As Worksheet
Set ws2 = Sheets.Add
Sheets.Add.Name = "Result"

MsgBox "Job Complete"
End Sub



Private Sub UserForm_Click()

End Sub

I hope I have managed to explain what I am trying to acheive and I would really appreciate any guidence with this. Thanks

Answer 1

Something like the below should do it. No doubt you will want to tweak bits but the general structure is there. I have commented what each block is doing - make sure you understand each line.

But normally for asking questions you should really really break the question down into its parts.

Like - "How do I loop through sheets", then "How do I find the last row of a sheet", then "How do I copy ranges" etc.

You would find that every single one of those has been asked before so in fact a little searching of Stackoverflow would be all that is needed.

Sub example()
    Dim ws As Worksheet, dWs As Worksheet 'variables for ws enumerator and destination ws
    Dim wb As Workbook 'variable to define the workbook context
    Dim sRng As Range, dRng As Range 'variables for source range and destination range

    Set wb = ActiveWorkbook

    'Add the results sheet and assign our current row range
    Set dWs = wb.Worksheets.Add
    Set dRng = dWs.Cells(2, 1)

    'Change the results sheet name (error if name exists so trap it)
    On Error Resume Next
    dWs.Name = "Result"
    On Error GoTo 0

    'Loop worksheets
    For Each ws In wb.Worksheets

        'Only work on the .csv sheet names
        If ws.Name Like "*.csv" Then

            'Find the row with the values on
            Set sRng = ws.Cells(ws.Rows.Count, 4).End(xlUp)
            'And set the range to be to the contiguous cells to the right
            Set sRng = ws.Range(sRng, sRng.End(xlToRight))

            'Add the sheet name to the results col A
            dRng.Value = ws.Name
            'Copy sRng to the output range
            sRng.Copy dRng(1, 2)

            'Increment output row to the next one
            Set dRng = dRng(2, 1)

        End If

    Next ws

    'Now just add the headers
    For Each dRng In dWs.Range(dWs.Cells(1, 2), dWs.Cells(1, dWs.Cells.Find("*", , XlFindLookIn.xlFormulas, , XlSearchOrder.xlByColumns, xlPrevious).Column))
        dRng.Value = "data " & dRng.Column - 1
    Next

End Sub