Excel Macro Excel to find a value and copy next row from that value

[Johnnyspa]

Hello all.

I don´t know too much about VBA, so I usually program in a "Frankestein" style. I look for parts of what I need and paste it together. But there is something I need that I can´t find.

I have several files, with several worksheets each one. I need to extract some values from each sheet to a summary one.

The problem is that the format is not the same on each sheet, so I need to look for the values I need.

In the row 24 there will be the headers, from B24 to J24. My match should be FRH,let´s imagine that it is in D24, Then I want the maacro to copy from D25 to H25 and all the rows until the end of the table.

Under the table there is more data, so I want it to stop in the first empty row.

The rest of the things that I need to do, I think I know how to do them.

Tomorrow I will copy my code right now, so you can see it if needed. But it is only coping all the tables (complete) from all the spreadsheets and files to a new one.

Thank you very much for your help.

Regards

 

[Johnnyspa]

Hello.

I don't know how to edit my post. I just want to add the macro I have already as maybe it can helps.

What it is doing is just creating a new sheet called "maps summary" and copiing them all the tables from all the files and all the worksheets in each file. But I need to look for specific data in the header and copy the following line, that column and the four next to that one.

If my label "FRH" appears in B25 I need to copy from B26 to F26. And if i appears in D25 then I need to copy from D26 to H26. And all the rows of the rows until first blank row.

I hope you can help me.

Here I paste my code:

Private Sub CommandButton1_Click()
Dim MyPath As String, FilesInPath As String
Dim MyFiles() As String
Dim SourceRcount As Long, FNum As Long
Dim mybook As Workbook, BaseWks As Worksheet
Dim sourceRange As Range, destrange As Range
Dim rnum As Long, CalcMode As Long
Dim FirstCell As String
Dim sh As Worksheet
Dim DestSh As Worksheet
Dim Last As Long
Dim CopyRng As Range


' Change this to the path\folder location of your files.
MyPath = "C:\temp\Merging Excels\files"
' Add a slash at the end of the path if needed.
If Right(MyPath, 1) <> "\" Then
MyPath = MyPath & "\"
End If
' If there are no Excel files in the folder, exit.
FilesInPath = Dir(MyPath & "*.xl*")
If FilesInPath = "" Then
MsgBox "No files found"
Exit Sub
End If
' Fill the myFiles array with the list of Excel files
' in the search folder.
FNum = 0
Do While FilesInPath <> ""
FNum = FNum + 1
ReDim Preserve MyFiles(1 To FNum)
MyFiles(FNum) = FilesInPath
FilesInPath = Dir()
Loop
' Set various application properties.
With Application
CalcMode = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
.EnableEvents = False
End With

'Delete the sheet "Maps Summary" if it exist
Application.DisplayAlerts = False
On Error Resume Next
ActiveWorkbook.Worksheets("Maps Summary").Delete
On Error GoTo 0
Application.DisplayAlerts = True

'Add a worksheet with the name "Maps Summary"
Set DestSh = ActiveWorkbook.Worksheets.Add
DestSh.Name = "Maps Summary"

' Loop through all files in the myFiles array.
If FNum > 0 Then
For FNum = LBound(MyFiles) To UBound(MyFiles)
Set mybook = Nothing
On Error Resume Next
Set mybook = Workbooks.Open(MyPath & MyFiles(FNum))
On Error GoTo 0
If Not mybook Is Nothing Then
On Error Resume Next
'loop through all worksheets and copy the data to the DestSh
For Each sh In ActiveWorkbook.Worksheets
If sh.Visible Then
'Find the last row with data on the DestSh
Last = LastRow(DestSh)

'Fill in the range that you want to copy
Set CopyRng = sh.Range("B8").CurrentRegion
End If
'This example copies values/formats, if you only want to copy the
'values or want to copy everything look at the example below this macro
CopyRng.Copy
With DestSh.Cells(Last + 1, "B")
.PasteSpecial xlPasteValues
.PasteSpecial xlPasteFormats
Application.CutCopyMode = False
End With
'Optional: This will copy the sheet name in the H column
DestSh.Cells(Last + 1, "A").Resize(CopyRng.Rows.Count).Value = sh.Name


Next
mybook.Close savechanges:=False


End If
Next
End If
ExitTheSub:
' Restore the application properties.
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = CalcMode
End With
End Sub

 

[Johnnyspa]

Hello,

Macro no longer needed. The thread can be close.

Regards

Jonathan