Consulting

Results 1 to 3 of 3

Thread: VBA - conditional copying different column ranges

  1. #1
    VBAX Newbie
    Joined
    Apr 2021
    Posts
    2
    Location

    VBA - conditional copying different column ranges

    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.
    Last edited by Aussiebear; 04-04-2021 at 01:19 AM. Reason: Wrapped supplied code in tags

  2. #2
    Moderator VBAX Sage SamT's Avatar
    Joined
    Oct 2006
    Location
    Near Columbia
    Posts
    7,814
    Location
    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
    I expect the student to do their homework and find all the errrors I leeve in.


    Please take the time to read the Forum FAQ

  3. #3
    VBAX Newbie
    Joined
    Apr 2021
    Posts
    2
    Location
    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 ��

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •