VBA - Loop for cell value to match worksheet name before copy and pasting

[abschy]

Hi guys, I'm a vba newbie and im currently having some issues writing out some vba code for this situation.

So I have a
1) Base worksheet which contains:
My base data:
Column B: different names of people
column A, C-J: other information which i pick and choose in the code below to copy

and
2) Multiple other worksheets in the same file with the names of the people:
Worksheet "Amy" contains 2 blocks of rows
- one to capture "opex" costs --> this data should start being pasted on A9 to H9
- one to capture "capex" costs (ie NOT opex) --> this data should start being pasted on A25 to H25

The code that I currently have to find the "last used row" for the 2 blocks of data works well but if theres any better way to write this, I'm all ears too! I havent been able to find any help on this because my data in column A is not continuous at all, hence the code i came up with below..

Back to the main problem..
the names in column B may not contain ALL the names of the worksheets
eg
column B contains: amy, brenda, catherine
but I have worksheets for: amy brenda catherine daphne elizabeth etc

I have already written the code to copy and paste the data for "amy" and it runs well but is there a way for this to loop for the rest of the names?

Thanks for the help!

This is the code i have now:

Private Sub CommandButton1_Click()


    a = Worksheets("Base Sheet").Cells(Rows.Count, 1).End(xlUp).Row
    For I = 2 To a


       
        If Worksheets("Base Sheet").Cells(I, 2).Value = "Amy" And Worksheets("Base Sheet").Cells(I, 3).Value = "Opex" Then
    
            
            Worksheets("Base Sheet").Range("D" & I, "J" & I).Copy
            Worksheets("Amy").Activate
            b = ActiveSheet.Cells(Rows.Count, "A").End(xlUp).Row
            Worksheets("Amy").Cells(b + 1, 1).Select
            Selection.PasteSpecial Paste:=xlPasteValues
            Worksheets("Base Sheet").Activate


        End If


        If Worksheets("Base Sheet").Cells(I, 2).Value = "Amy" And Worksheets("Base Sheet").Cells(I, 3).Value <> "Opex" Then


            Worksheets("Base Sheet").Range("D" & I, "J" & I).Copy
            Worksheets("Amy").Activate
            c = ActiveSheet.Range("A7").End(xlDown).Row
            Worksheets("Amy").Cells(c + 1, 1).Select
            Selection.PasteSpecial Paste:=xlPasteValues
            Worksheets("Base Sheet").Activate


        End If
    
    Next
    
Next
Application.CutCopyMode = False
ThisWorkbook.Worksheets("Base Sheet").Cells(1, 1).Select


End Sub

 

[Brombrough]

Hi abschy,

If I read your instructions right I've created the following code.

If it's what you require enjoy.

Private Sub CommandButton1_Click()
Dim i As Long
Dim wb As Workbook
Dim wsBS As Worksheet
Dim ws As Worksheet

Dim lngwsBSMaxRow As Long
Dim lngwsMaxRow As Long
Dim blnwsExists As Boolean
Dim strwsName As String

Set wb = ThisWorkbook

Set wsBS = wb.Worksheets("Base Sheet")

lngwsBSMaxRow = wsBS.Range("B1048576").End(xlUp).Row

For i = 2 To lngwsBSMaxRow
If Len(wsBS.Range("B" & i).Value) > 0 Then 'dont want blank in Column "B"
GoSub Checkws
If blnwsExists = True Then 'check if worksheet exists
lngwsMaxRow = ws.Range("A1048576").End(xlUp).Row 'get last row of none base sheet
If wsBS.Range("C" & i).Value = "Opex" Then
wsBS.Range("D" & i, "J" & i).Copy ws.Range("A" & lngwsMaxRow + 1) 'Opex
Else
wsBS.Range("D" & i, "J" & i).Copy ws.Range("A" & lngwsMaxRow + 1) 'Not Opex
End If
End If
End If
Next i

wsBS.Activate
wsBS.Range("A1").Activate
Application.CutCopyMode = False
On Error GoTo 0
On Error Resume Next
Set wb = Nothing
Set wsBS = Nothing
Set ws = Nothing

Exit Sub

Checkws:
blnwsExists = False
strwsName = wsBS.Range("B" & i).Value
On Error GoTo nows
Set ws = wb.Worksheets(strwsName)
blnwsExists = True

nows:
Return
End Sub

 

[dmt32]

Hi,
untested but see if this update to your code helps

Private Sub CommandButton1_Click()
    Dim a As Long, b As Long, I As Long
    Dim wsBaseSheet As Worksheet, wsStaffName As Worksheet
    Dim StaffName As String, CostType As String
    
    Set wsBaseSheet = ThisWorkbook.Worksheets("Base Sheet")
    
    a = wsBaseSheet.Cells(wsBaseSheet.Rows.Count, 1).End(xlUp).Row
    
    For I = 2 To a
'get staff name
        StaffName = wsBaseSheet.Cells(I, 2).Value
'cost type
        CostType = wsBaseSheet.Cells(I, 3).Value
'check sheet exists
        If Len(StaffName) > 0 And Evaluate("ISREF('" & StaffName & "'!A1)") Then
'set object variable to worksheet
        Set wsStaffName = ThisWorkbook.Worksheets(StaffName)
'copy base sheet ranges
            wsBaseSheet.Range("D" & I, "J" & I).Copy
'paste to staff name sheet range
            With wsStaffName
                    b = IIf(CostType = "Opex", .Cells(.Rows.Count, "A").End(xlUp).Row + 1, _
                                                      .Range("A7").End(xlDown).Row + 1)
                    .Cells(b, 1).PasteSpecial Paste:=xlPasteValues
            End With
        End If
'clear
        Application.CutCopyMode = False
        Set wsStaffName = Nothing
    Next I
End Sub

Dave

 

[abschy]

Thanks Dave for your help!! It worked great!
However, as my data is constantly growing, I need the data to be copied over every week or so - so the pasting should be done at the next empty row. Currently, if i run this code more than once, it will paste the data in the same line.
Is there a way to have the pasting range be updated to the next available row?

Thank you!!

 

[dmt32]

Hi,

this line

b = IIf(CostType = "Opex", .Cells(.Rows.Count, "A").End(xlUp).Row + 1, _
                                                      .Range("A7").End(xlDown).Row + 1)

code in red is taken from code you posted and at the end, I added +1 which should increment the data to be pasted to next blank row.
If still having problems place copy of your workbook with sample data in dropbox and provide link to it here.


Dave

 

[abschy]

Hi Dave,
I managed to fix it already and it works great!
Thanks so much!!!