VBA - conditional copying different column ranges

[brenda45]

Ok, so I would really appreciate help. Basically I have a raw data table where a customer can choose up to 3 different courses, data is in 3 columns. But I need to be able to have a complete table where if a customer selects 3 courses, her details appear in 3 different rows. The paste destination is always the same, but the copy range is slightly different. I have got the code to duplicate rows for more than 1 selection, but I can't get it to copy the selected columns as opposed to the whole row. I have tried defining selection ranges with each if statement and arrays but I am at a complete loss so any advice would save me sanity. Code so far (such that it is, is below) - I had to use paste special values as there are formulae in the original table picking up from another spreadsheet, which I dont want in the final version.



Private Sub CommandButton1_Click()
ScreenUpdating = False
Dim modules As Range
Dim wb As Range
Dim arom As Range
Dim med As Range
Dim Source As Worksheet
Dim Target As Worksheet
Set Source = ActiveWorkbook.Worksheets("Raw Table")
Set Target = ActiveWorkbook.Worksheets("Finished Table")
' Start copying to row 4 in target sheet
j = 4
For Each wb In Source.Range("K4:K1000")
If wb = "Well being course" Then
Source.Rows(cwb.Row).Copy
' to only copy A:E,K:L,S:U
Target.Rows(j).PasteSpecial Paste:=xlPasteValues
'to paste into Cols A:J
j = j + 1
End If
Next wb
For Each arom In Source.Range("M4:M100") 'Do 1000 rows
If arom = "Aromatherapy" Then
Source.Rows(arom.Row).Copy
' to only copy A:E, M:N, S:U
Target.Rows(j).PasteSpecial Paste:=xlPasteValues
'to paste into Cols A:J
j = j + 1
End If
Next arom
For Each med In Source.Range("O4:O100") 'Do 1000 rows
If med = "Meditation" Then
Source.Rows(med.Row).Copy
' to only copy A:E, O:P, S:U
Target.Rows(j).PasteSpecial Paste:=xlPasteValues
'to paste into Cols A:J
j = j + 1
End If
Next med
ScreenUpdating = False
End Sub

Many thanks.

[SamT]

I Renamed all variables named after KeyWords and removed duplicates. Also, I hate overloading Event Subs, so I put the working code into its own Procedure.

Option Explicit

Private Sub CommandButton1_Click()
MoveDataToFinishedTable
End Sub

Private Sub MoveDataToFinishedTable()
Dim Cel As Range
Dim Src As Worksheet
Dim Trgt As Worksheet
Dim Rw As Long
Dim Lr As Long

Set Src = ActiveWorkbook.Worksheets("Raw Table")
Set Trgt = ActiveWorkbook.Worksheets("Finished Table")
With Src 'Find Required Rows
Lr = WorksheetFunction.Max(.Cells(Rows.Count, "K").End(xlUp).Row, _
.Cells(Rows.Count, "M").End(xlUp).Row, _
.Cells(Rows.Count, "O").End(xlUp).Row)

' Start copying to row 4 in Trgt sheet
Rw = 4

Application.ScreenUpdating = False

For Each Cel In .Range("K4:K" & Lr) 'Do Required rows
If Cel = "Well being course" Then
' to only copy A:E,K:L,S:U
.Rows(Cel.Row).Union(Range("A:E"), Range("K:L"), Range("S:U")).Copy
Trgt.Cells(Rw, "A").PasteSpecial Paste:=xlPasteValues
'to paste into Cols A:Rw
Rw = Rw + 1
End If
Next Cel

For Each Cel In .Range("M4:M" & Lr) 'Do Required rows
If Cel = "Celatherapy" Then
' to only copy A:E, M:N, S:U
.Rows(Cel.Row).Union(Range("A:E"), Range("M:N"), Range("S:U")).Copy
Trgt.Cells(Rw, "A").PasteSpecial Paste:=xlPasteValues
'to paste into Cols A:Rw
Rw = Rw + 1
End If
Next Cel

For Each Cel In .Range("O4:O" & Lr) 'Do Required rows
If Cel = "Celitation" Then
' to only copy A:E, O:P, S:U
.Rows(Cel.Row).Union(Range("A:E"), Range("O:P"), Range("S:U")).Copy
Trgt.Cells(Rw, "A").PasteSpecial Paste:=xlPasteValues
'to paste into Cols A:Rw
Rw = Rw + 1
End If
Next Cel

End With 'Src

Application.ScreenUpdating = True
End Sub

[brenda45]

Firstly apologies in delay in responding. Secondly huge thanks for the code, very appreciated!!! I’ve never actually seen the union coding in practice before and take your point about separate procedures, it is a nasty habit of mine ��