Copy/Paste based on Criteria

[Dan R.]

I'm using the following code to open a WB, copy and paste a range into
it, then copy and paste
the results back into the ActiveSheet, but what I'd like to do is
this:

For cells in WB1.Range("A2:B16") where WB1.Range("C2:C16") = "A"
then copy and paste to [Area 1]
-Or-
For cells in WB1.Range("A2:B16") where WB1.Range("C2:C16") = "B"
then copy and paste to [Area 2]

Here's my code:

Sub Generate_H7()
Dim SourceRange1 As Range
Dim SourceRange2 As Range
Dim DestRange1 As Range
Dim DestRange2 As Range
Dim WB1 As Worksheet
Dim WB2 As Workbook

Application.ScreenUpdating = False

Set WB1 = ActiveSheet
Set WB2 = Workbooks.Open("A:\Lookup.xls")

Set SourceRange1 = WB1.Range("A2:B16")
Set SourceRange2 = WB2.Sheets(13).Range("F3:F17")
Set DestRange1 = WB2.Sheets(13).Range("B3")
Set DestRange2 = WB1.Range("D2")

SourceRange1.Copy
DestRange1.PasteSpecial xlPasteValues, , False, False
Application.CutCopyMode = False

SourceRange2.Copy
DestRange2.PasteSpecial xlPasteValues, , False, False
Application.CutCopyMode = False

DestRange2.EntireColumn.AutoFit

WB2.Close savechanges:=False
Application.ScreenUpdating = True

End Sub

Thank You,
-- Dan

 

[merjet]

I picked two areas on the same sheet, but you could easily change
them.

Sub macro1()
Dim ws As Worksheet
Dim iA As Integer
Dim iB As Integer
Dim c As Range
Dim rng As Range

Set ws = Worksheets("Sheet1")
Set rng = ws.Range("C2:C16")
For Each c In rng
If c = "A" Then
iA = iA + 1
ws.Cells(iA, 5) = c.Offset(0, -2)
ws.Cells(iA, 6) = c.Offset(0, -1)
Else
iB = iB + 1
ws.Cells(iB, 8) = c.Offset(0, -2)
ws.Cells(iB, 9) = c.Offset(0, -1)
End If
Next c
End Sub

Hth,
Merjet

 

[Dan R.]

Excellent, thanks Merjet. That's what I needed.

-- Dan