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

MattyB1983

New Member
Joined
May 31, 2018
Messages
5
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
 

Excel Facts

Links? Where??
If Excel says you have links but you can't find them, go to Formulas, Name Manager. Look for old links to dead workbooks & delete.
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.

Code:
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
 
Upvote 0
Welcome to the board.
Try:
Code:
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.
Code:
Sheets("Sheet1").Activate
Range("A1").Select
Range("A1").Value = 1
Can be reduced to
Code:
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
 
Last edited:
Upvote 0
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...
 
Upvote 0
Hi There,

Thanks so much for this, it has done the trick perfectly..... A star :smile:
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...
 
Upvote 0
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)
 
Upvote 0
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:
Code:
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
 
Last edited:
Upvote 0
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
 
Upvote 0
What error does that line give? There may be something else in your setup not described? Not sure what else to suggest..
 
Upvote 0
Hi Matty, found a error, extra code added in blue. Check the code below contains the correct worksheet names as well and try:
Rich (BB code):
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
 
Last edited:
Upvote 0

Forum statistics

Threads
1,223,904
Messages
6,175,295
Members
452,633
Latest member
DougMo

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top