How to construct a loop - find cell A by content, but paste cell B into another workbook.

[markthewatercooler2]

Hey guys,

I've been lurking in the existing threads, but not sure how to approach it yet. Should be straightforward, but I'm not very competent with syntax. Consider this table.

[TABLE="width: 300"]
<tbody>[TR]
[TD]Patient id - 336[/TD]
[TD]Diagnosed[/TD]
[TD]Diabetes Type 1[/TD]
[/TR]
[TR]
[TD][/TD]
[TD]Age[/TD]
[TD]32[/TD]
[/TR]
[TR]
[TD][/TD]
[TD]Insurance number[/TD]
[TD]GP notes text[/TD]
[/TR]
[TR]
[TD]Patient id - 118[/TD]
[TD]Diagnosed[/TD]
[TD]Diabetes Type 1[/TD]
[/TR]
[TR]
[TD][/TD]
[TD]Age[/TD]
[TD]21[/TD]
[/TR]
[TR]
[TD][/TD]
[TD]Insurance number[/TD]
[TD]GP notes text[/TD]
[/TR]
[TR]
[TD]Patient id - 724[/TD]
[TD]Diagnosed[/TD]
[TD]Diabetes Type 2[/TD]
[/TR]
[TR]
[TD][/TD]
[TD]Age[/TD]
[TD]46[/TD]
[/TR]
[TR]
[TD][/TD]
[TD]Insurance number[/TD]
[TD]GP notes text[/TD]
[/TR]
</tbody>[/TABLE]


Etc. Imagine hundreds of records. I would now like to separate Type 1 people into a separate workbook in the following way.

[TABLE="width: 300"]
<tbody>[TR]
[TD]Insurance number[/TD]
[TD]Patient id - 336[/TD]
[TD]GP notes text[/TD]
[/TR]
[TR]
[TD]Insurance number[/TD]
[TD]Patient id - 118[/TD]
[TD]GP notes text[/TD]
[/TR]
</tbody>[/TABLE]

What kind of a loop do I need to use to tell Excel to only take certain cells and keep doing this until the document ends?

 

[JLGWhiz]

Assuming that there are three rows per record and that the second line on some rows is due to word wrap, See if this procedure does what you want. I suggest you test it on a copy of your file, or a mock up, before you apply it to your original. It is also assumed that the data resides in columns A:C with not header row. Copy this prcedure to your standard code module 1.

Sub newSht()
Dim sh As Worksheet, lr As Long, rng As Range, c As Range, wb As Workbook, nuSh As Worksheet, rg As Range
Set sh = Sheets(1) 'Edit sheet name - this is source sheet
lr = sh.Cells(Rows.Count, 3).End(xlUp).Row
Set rng = sh.Range("C1:C" & lr)
Set wb = Workbooks.Add
Set nuSh = wb.Sheets(1)
wb.SaveAs "Type 1.xlsx" 'If you are not using Excel2007 or > then edit the file extension
    For Each c In rng
        If Right(c.Value, 6) = "Type 1" Then
            Set rg = nuSh.Cells(Rows.Count, 1).End(xlUp)(2)
            rg = c.Offset(2, -1).Value
            rg.Offset(0, 1) = c.Offset(0, -2).Value
            rg.Offset(0, 2) = c.Offset(2, 0)
        End If
    Next
wb.Close True
End Sub

How it works. A new workbook will be created and named "Type 1". The code will walk down column C of the source worksheet to locate the phrase "Type 1". When found it will then copy the three designated elements to the new workbook, sheet 1. When completed, it will close and save the new workbook.