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

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