Excel/VBA to copy range based on cell value
Happy New Year to you. I need help with this problem.
I use a macro in Excel 2007 that extracts data from word tables contained within word files a folder. each folder may contain varying number of word files.Macro works fine. tables are identical. Each table data is is extracted to sing row, one below the other, starting from row 1. For example if the folder contains 200 files there will be 200 rows of data.
When extracted each heading will be in one column and the data in the adjoining column in the same row. For example if there are 50 headings and correspond number of responses, results in 100 columns of data per row.
The problem is that although the tables are identical, in actual extraction after first 8 columns headings do not align and randomly get shifted. may be due to respondents using return key etc. I use another macro to remove the little squares.
I need a macro than will look for the cell value "Report.No" in each row and copies the following from that row to a master sheet:
1.First 8 column data then
2.Values found in 1st and 3rd adjacent cells in the same row after the cell containing the text value "Report No.".
If the original files had 200 rows and 50 columns, master sheet will have 200 rows and 10 columns.
Thank you for your previous prompt helps!
This worked for me if I understood the situation correctly. It works on the active sheet. It writes to a sheet name "Master" (which you can change in the code).
Dim sh As Worksheet, sh1 As Worksheet, rw1 As Long
Dim r As Range, rr As Range, cell As Range
Set sh = ActiveSheet
Set sh1 = Worksheets("Master")
rw1 = 1
Set r = sh.Range("A1", sh.Cells(sh.Rows.Count, 1).End(xlUp))
For Each cell In r
If Application.CountIf(cell.EntireRow, "*Report No.*") > 0 Then
res = Application.Match("*Report No.*", sh.Rows(cell.Row), 0)
cell.Resize(1, 8).Copy sh1.Cells(rw1, 1)
Set rr = sh.Cells(cell.Row, res)
sh1.Cells(rw1, 9) = rr.Offset(0, 1)
sh1.Cells(rw1, 10) = rr.Offset(0, 3)
rw1 = rw1 + 1