If value in column B = 1, then copy and paste content of Column A to another sheet.

[MattyB1983]

Hi all.

I am little new to Excel coding and would really appreciate some help. I am writing an excel sheet for my students but getting stuck, essentially they will fill out a sheet scoring themselves from 1 to 5 in certain areas, Col A will have 50 skills, they will rate themselves 1 to 5 in each of these areas. If the Value is 1 (or 2 as well in this case but don't worry about that) in Col B, I want the macro to copy the skill set in Col A (same row) and then copy and paste it to another sheet for future self assessments. I have written the below that activates on a command button, however it is copy and pasting the entire row, I do not want this. I just want the content of Col A, to cut and paste into another Col A on a different sheet: as below. Thank you in advance to any experts out there as this is a bit beyond me.

Private Sub CommandButton1_Click()

Application.ScreenUpdating = False

a = Worksheets("GAPs").Cells(Rows.Count, 1).End(xlUp).Row

For i = 25 To a

If Worksheets("GAPs").Cells(i, 2).Value = "1" Then
Worksheets("GAPs").Rows(i).Copy
Worksheets("Post Gaps Sessions").Activate
b = Worksheets("Post Gaps Sessions").Cells(Rows.Count, 1).End(xlUp).Row
Worksheets("Post Gaps Sessions").Cells(b + 1, 1).Select
ActiveSheet.Paste
Worksheets("GAPs").Activate

End If

If Worksheets("GAPs").Cells(i, 2).Value = "2" Then
Worksheets("GAPs").Rows(i).Copy
Worksheets("Post Gaps Sessions").Activate
b = Worksheets("Post Gaps Sessions").Cells(Rows.Count, 1).End(xlUp).Row
Worksheets("Post Gaps Sessions").Cells(b + 1, 1).Select
ActiveSheet.Paste
Worksheets("GAPs").Activate

End If


Next
Application.CutCopyMode = False
ThisWorkbook.Worksheets("GAPs").Cells(1, 1).Select
Application.ScreenUpdating = True
End Sub

 

[steve the fish]

Hi. Heres a macro that may help. The only caveat is that you need headers in the sheets. This one assumes the headers are in row 1.

Sub FilterMacro()

Application.ScreenUpdating = False
 
Dim lr As Long, lrPGS As Long

lrPGS = Worksheets("Post Gaps Sessions").Range("A" & Rows.Count).End(xlUp).Row
With Sheets("GAPs")
    If .AutoFilterMode Then .AutoFilterMode = False
    lr = .Range("B" & .Rows.Count).End(xlUp).Row
    If lr < 2 Then Exit Sub
    With .Range("B1:B" & lr)
        .AutoFilter
        .AutoFilter Field:=1, Criteria1:="<=2"
        If .SpecialCells(xlCellTypeVisible).Count > 1 Then
            .Offset(1, -1).Resize(lr - 1).SpecialCells(xlCellTypeVisible).Copy _
            Worksheets("Post Gaps Sessions").Range("A" & lrPGS + 1)
        End If
    End With
    .AutoFilterMode = False
End With

Application.ScreenUpdating = True

End Sub

 

[JackDanIce]

Welcome to the board.
Try:

Private Sub CommandButton1_Click()

    Dim x       As Long
    Dim arr()   As Variant

    With Sheets("GAPs")
        'Find lastrow in column A above 25
        x = Application.Max(25, .Cells(.Rows.Count, 1).End(xlUp).Row)
        'Read data into array
        arr = .Cells(25, 1).Resize(x - 24, 2).Value
    End With
    
    For x = LBound(arr, 1) To UBound(arr, 1)
        'Clear value in column 1 of array if column 2 of array is 3 or more
        arr(x, 1) = IIf(arr(x, 2) < 3, arr(x, 1), vbNullString)
    Next x
    
    With Sheets("Post Gaps Sessions")
        With .Cells(.Rows.Count, 1).End(xlUp).Offset(1).Resize(UBound(arr, 1))
            'Print column 1 of array only
            .Value = Application.Index(arr, 0, 1)
            'Remove blank cells
            .SpecialCells(xlCellTypeBlanks).Delete xlUp
        End With
    End With
    
    Erase arr
    
End Sub

As a general comment, you do not need to use .Select or .Activate in your code, this is just an attribute/action/or property of the object and tends to slow code execution.

E.g.

Sheets("Sheet1").Activate
Range("A1").Select
Range("A1").Value = 1

Can be reduced to

Sheets("Sheet1").Value = 1

.Select or .Activate is an action on the Sheets("Sheet1") object. Whether the sheet is selected or not, we can still write 1 into cell A1 of the sheet

 

[MattyB1983]

Hi There,

Thanks so much for this, it has done the trick perfectly..... A star
I have tried to break this down so I understand it and can apply it myself, but it has gone over my head, If I could ask one more thing, it would finish the work, keeping the above the exact same and just adding the following, is it possible to add the following instruction to the same command,

If 1 in Col B, Cut and Paste Col A in GAPS into = Col A in the 'Post GAPs Analysis' sheet
If 2 in Col B, Cut and Paste Col A in GAPS into = Col B in the 'Post GAPs Analysis' sheet
If 3 in Col B, Cut and Paste Col A in GAPS into = Col C in the 'Post GAPs Analysis' sheet

Next available cell etc....

Thanks so much for you help so far...

 

[MattyB1983]

Hi There,

Thanks so much for this, it has done the trick perfectly..... A star
I have tried to break this down so I understand it and can apply it myself, but it has gone over my head, If I could ask one more thing, it would finish the work, keeping the above the exact same and just adding the following, is it possible to add the following instruction to the same command,

If 1 in Col B, Cut and Paste Col A in GAPS into = Col A in the 'Post GAPs Analysis' sheet
If 2 in Col B, Cut and Paste Col A in GAPS into = Col B in the 'Post GAPs Analysis' sheet
If 3 in Col B, Cut and Paste Col A in GAPS into = Col C in the 'Post GAPs Analysis' sheet

Next available cell etc....

Thanks so much for you help so far...

 

[MattyB1983]

Sorry that was addressed to Steve the Fish.

Jack thank you also for your work, unfortunately we get stuck at .Value = Application.Index(arr, 0, 1)

 

[JackDanIce]

That's odd, I retried it with a mock-up of your sheets, values 1 to 6 in A26:A31 and values 1 to 6 in B26:B31 in a sheet named GAPs.
Ran the code, no error message and only values 1 and 2 appear in A2:A3 respectly in a sheet named Post Gaps Sessions.

Slight edit to include the additional request (and remove the line causing you error), try:

Private Sub CommandButton1_Click()\

    Dim x       As Long
    Dim LR      As Long
    Dim arr()   As Variant
    
    With Sheets("GAPs")
        'Find lastrow in column A above 25
        x = Application.Max(25, .Cells(.Rows.Count, 1).End(xlUp).Row)
        'Read data into array
        arr = .Cells(25, 1).Resize(x - 24, 2).Value
    End With
    
    With Sheets("Post Gaps Sessions")
        For x = LBound(arr, 1) To UBound(arr, 1)
            .Cells(.Rows.Count, arr(x, 2)).End(xlUp).Offset(1).Value = arr(x, 1)
        Next x
    End With
            
    Erase arr
    
End Sub

 

[MattyB1983]

Thanks Jack.

Unfortunately it does not work. it stops at ".Cells(.Rows.Count, arr(x, 2)).End(xlUp).Offset(1).Value = arr(x, 1)"

Not sure why sorry, thanks so much for any help by the way, I do value it

 

[JackDanIce]

What error does that line give? There may be something else in your setup not described? Not sure what else to suggest..

 

[JackDanIce]

Hi Matty, found a error, extra code added in blue. Check the code below contains the correct worksheet names as well and try:

Private Sub CommandButton1_Click()

    Dim x       As Long
    Dim LR      As Long
    Dim arr()   As Variant
    
    With Sheets("GAPs")
        'Find lastrow in column A above 25
        x = Application.Max(25, .Cells(.Rows.Count, 1).End(xlUp).Row)
        'Read data into array
        arr = .Cells(25, 1).Resize(x - 24, 2).Value
    End With
    
    With Sheets("Post Gaps Sessions")
        For x = LBound(arr, 1) To UBound(arr, 1)
            If LenB(arr(x, 2)) Then .Cells(.Rows.Count, arr(x, 2)).End(xlUp).Offset(1).Value = arr(x, 1)
        Next x
    End With
            
    Erase arr
    
End Sub