VBA Finding keywords then copying nearby rows of variable length

rockclimber

New Member
Joined
Jun 27, 2019
Messages
3
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

Keyword1111112113114------
Keyword2Subkey1333333333333333333
Subkey21-Oct2-Oct3-Oct4-Oct------
Subkey3211------214215216

<tbody>
</tbody>

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

Well-known Member
Joined
Apr 11, 2012
Messages
8,543
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

New Member
Joined
Jun 27, 2019
Messages
3
> 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

Well-known Member
Joined
Apr 11, 2012
Messages
8,543
Try:
Code:
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

New Member
Joined
Jun 27, 2019
Messages
3
Made a few adjustments (e.g. got rid of the transposing) but helped me a lot, thanks!
 

Forum statistics

Threads
1,082,612
Messages
5,366,610
Members
400,906
Latest member
incanus

Some videos you may like

This Week's Hot Topics

Top