Find Text Within A Row, Then Copy Information Below That Cell To Second Worksheet

[kstoneman]

I’ve recently taken over an Excel workbook that uses VBA to find, copy, and paste information between two workbooks. I’m relatively new to Excel VBA coding, so I’m looking for any help that will reduce the vast number of lines, over 300, of redundant coding. I will be unable to provide the actual coding as it includes sensitive information and would take a lot of time to make the coding genetic. Here is what I want to accomplish:

• Find each instance of text within a row range
• Once I find a cell with text, I want to copy the cell and a 5x5 block of information, which is two rows below that cell, to another workbook
• The copied information needs to be appended to the last used row in the second worksheet

I’ve searched the web for ideas on how to accomplish this. I can find snippets of coding that can do some parts, but I don’t know how to consolidate and organize the coding into a single process.

The attached file is a very raw example of the type of data I’m using. The three blocks of values on the source tab need to be pasted into the destination worksheet. Currently, in the destination tab is the format/result required.

Any help is greatly appreciated.

Example 1.xlsx
	A	B	C	D	E	F	G	H	I	J	K	L	M	N	O	P	Q	R
1
2	type	C						SS						1B
3		145	15	3	14	11		128	21	3	21	9		129	23	4	17	5
4		140	18	4	16	6		127	40	12	25	11		153	39	6	26	4
5		0	0	0	0	0		106	8	4	11	0		58	7	4	18	2
6		77	7	2	7	0		119	23	4	18	16		98	11	3	13	4
7		42	10	3	9	3		129	22	6	22	0		125	20	4	14	3
Source

Example 1.xlsx
	A	B	C	D	E	F
3	type	val1	val2	val3	val4	val5
4	C	145	15	3	14	11
5	C	140	18	4	16	6
6	C	0	0	0	0	0
7	C	77	7	2	7	0
8	C	42	10	3	9	3
9	SS	128	21	3	21	9
10	SS	127	40	12	25	11
11	SS	106	8	4	11	0
12	SS	119	23	4	18	16
13	SS	129	22	6	22	0
14	1B	129	23	4	17	5
15	1B	153	39	6	26	4
16	1B	58	7	4	18	2
17	1B	98	11	3	13	4
18	1B	125	20	4	14	3
Destination

 

[Peter_SSs]

I suggest that you update your Account details (or click your user name at the top right of the forum) so helpers always know what Excel version(s) & platform(s) you are using as the best solution often varies by version. (Don’t forget to scroll down & ‘Save’)

Based on the sample data layout above and assuming ...

1. Headers exist already in 'Destination' (though code could add them if required)
2. Values in 'Source' row 3 are constants (that is, not the result of formulas)

.. give this a try with a copy of your workbook.

Sub Copy_Blocks()
  Dim rA As Range

  For Each rA In Sheets("Source").Rows(3).SpecialCells(xlConstants).Areas
    rA.Resize(5).Copy Destination:=Sheets("Destination").Range("B" & Rows.Count).End(xlUp).Offset(1)
    Sheets("Destination").Range("A" & Rows.Count).End(xlUp).Offset(1).Resize(5).Value = rA.Cells(0, 1).Value
  Next rA
End Sub

 

[Fluff]

Cross-posting (posting the same question in more than one forum) is not against our rules, but the method of doing so is covered by #13 of the Forum Rules.

Be sure to follow & read the link at the end of the rule too!

Cross posted at: Find Text Within A Row, Then Copy Information Below That Cell To Second Worksheet
and Find Text Within A Row, Then Copy Information Below That Cell To Second Worksheet
and Find Text Within A Row, Then Copy Information Below That Cell To Second Worksheet

If you have posted the question at more places, please provide links to those as well.

If you do cross-post in the future and also provide links, then there shouldn’t be a problem.