VBA Finding keywords then copying nearby rows of variable length

[rockclimber]

Hi, thanks in advance for any help, I realize it's a lot. I'm trying to take one sheet and upload data to another. The task is:

1) Find Keyword 1 on Sheet 1
2) Skip 3 columns and copy a varying number (based on source sheet) of columns with data; below would be 4 columns (111 thru 114) but it could be 3, 10, 20, etc. in total; note that --- is not an empty cell
3) Paste this row on Sheet 2 starting at "C8" thru "[]8" ([] depends on number of cells copied)
4) Find Keyword 2 on Sheet 1
5) Find Subkey 2 and 3 based on location of Keyword 2 (they are always one column right, but variable row)
6) Copy rows Subkey 2 and 3, but only the same columns as 111 thru 114; 4 in total below, so the 4 dates and 211 thru 214 (even the middle --- in this case)
7) Paste these rows in "C9" thru "[]9" and "C10" thru "[]10" on other sheet

[TABLE="class: grid, width: 500"]
<tbody>[TR]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD][/TD]
[TD][/TD]
[TD]Keyword1[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD]111[/TD]
[TD]112[/TD]
[TD]113[/TD]
[TD]114[/TD]
[TD]---[/TD]
[TD]---[/TD]
[TD][/TD]
[/TR]
[TR]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD][/TD]
[TD]Keyword2[/TD]
[TD]Subkey1[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD]333[/TD]
[TD]333[/TD]
[TD]333[/TD]
[TD]333[/TD]
[TD]333[/TD]
[TD]333[/TD]
[TD][/TD]
[/TR]
[TR]
[TD][/TD]
[TD][/TD]
[TD]Subkey2[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD]1-Oct[/TD]
[TD]2-Oct[/TD]
[TD]3-Oct[/TD]
[TD]4-Oct[/TD]
[TD]---[/TD]
[TD]---[/TD]
[TD][/TD]
[/TR]
[TR]
[TD][/TD]
[TD][/TD]
[TD]Subkey3[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD]211[/TD]
[TD]---[/TD]
[TD]---[/TD]
[TD]214[/TD]
[TD]215[/TD]
[TD]216[/TD]
[TD][/TD]
[/TR]
[TR]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
</tbody>[/TABLE]

I can find the Keywords with .Find but I have no fixed cells to work with, so I'm stuck how to select the data to copy and paste. Thanks again for any ideas you can share!

 

[mumps]

The screen shot of your data doesn't show the column letters or row numbers so we can't tell exactly where the data is located on the sheet. Can you post a screen shot of what your data actually looks like? Section B at this link has instructions on how to post a screen shot: https://www.mrexcel.com/forum/board-announcements/127080-guidelines-forum-use.html Alternately, you could upload a copy of your file to a free site such as www.box.com. or www.dropbox.com. Once you do that, mark it for 'Sharing' and you will be given a link to the file that you can post here. Include a detailed explanation of what you would like to do referring to specific cells, rows, columns and worksheets. If the workbook contains confidential information, you could replace it with generic data.

 

[rockclimber]

> The screen shot of your data doesn't show the column letters or row numbers

That's the point, the columns and rows aren't fixed and change by sheet to sheet, only relative locations based on the keywords are set.

 

[mumps]

Try:

Sub CopyRange()
    Application.ScreenUpdating = False
    Dim KW1 As Range, KW2 As Range, SB2 As Range, SB3 As Range, fnd As Range
    Dim srcWS As Worksheet, desWS As Worksheet, bottomC As Long, LastRow As Long
    Set srcWS = Sheets("Sheet1")
    Set desWS = Sheets("Sheet2")
    LastRow = srcWS.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    Set KW1 = srcWS.UsedRange.Find("Keyword1", LookIn:=xlValues, lookat:=xlWhole)
    If Not KW1 Is Nothing Then
        Set fnd = Rows(KW1.Row).Find("---", LookIn:=xlValues, lookat:=xlWhole)
        If Not fnd Is Nothing Then
            bottomC = desWS.Range("C" & desWS.Rows.Count).End(xlUp).Row
            If bottomC < 8 Then
                Range(Cells(KW1.Row, KW1.Column + 4), Cells(KW1.Row, fnd.Column - 1)).Copy
                desWS.Range("C8").PasteSpecial Transpose:=True
            Else
                Range(Cells(KW1.Row, KW1.Column + 4), Cells(KW1.Row, fnd.Column - 1)).Copy
                desWS.Cells(desWS.Rows.Count, "C").End(xlUp).Offset(1, 0).PasteSpecial Transpose:=True
            End If
        End If
    End If
    Set KW2 = srcWS.UsedRange.Find("Keyword2", LookIn:=xlValues, lookat:=xlWhole)
    If Not KW2 Is Nothing Then
        Set SB2 = srcWS.Range(srcWS.Cells(KW2.Row, KW2.Column + 1), srcWS.Cells(LastRow, KW2.Column + 1)).Find("Subkey2", LookIn:=xlValues, lookat:=xlWhole)
        If Not SB2 Is Nothing Then
            Range(Cells(SB2.Row, KW1.Column + 4), Cells(SB2.Row, fnd.Column - 1)).Copy
            desWS.Cells(desWS.Rows.Count, "C").End(xlUp).Offset(1, 0).PasteSpecial Transpose:=True
        End If
        Set SB3 = srcWS.Range(srcWS.Cells(KW2.Row, KW2.Column + 1), srcWS.Cells(LastRow, KW2.Column + 1)).Find("Subkey3", LookIn:=xlValues, lookat:=xlWhole)
        If Not SB3 Is Nothing Then
            Range(Cells(SB3.Row, KW1.Column + 4), Cells(SB3.Row, fnd.Column - 1)).Copy
            desWS.Cells(desWS.Rows.Count, "C").End(xlUp).Offset(1, 0).PasteSpecial Transpose:=True
        End If
    End If
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
End Sub

 

[rockclimber]

Made a few adjustments (e.g. got rid of the transposing) but helped me a lot, thanks!

 

[mumps]

You are very welcome.