SO close, yet so far -Macro to move balance data from wksht to another wksht-

[wmehar]

Thank you in advance for your help. I have two worksheets, one with census data (Sheet1) and another with account balance data (Table 1). I'm trying to come up with a code that transfers the individuals account balances between the sheets.

I'm able to get the code to match up names with the chart, check which account source ("Profit Sharing" in this example) and to bring the data where I want it. However, the only problem is that it pastes every iteration of every persons balance in each cell where they need to go, ultimately with the last balance pasted uniformly into Sheet1.

For example:

John: pastes Johns, Bills, Dillans, then pastes Jerry's Profit Sharing data in cell cell P1
Bill: pastes Johns, Bills, Dillans, then pastes jerry's Profit Sharing data in cell P2
.
.
Jerry: pastes Johns, Bills, Dills, then pastes Jerry's Profit Sharing data in cell P4.

The thing is, I don't want to change the coding I currently have too much, because I'm setting this up for difference census's with different reports, and would just like to automate doing this for 100's of people across different sheets with the same sheet names. So things need to be dynamic. Again I appreciate any kind of help on this.

I plan extrapolating so it wouldn't be just Profit Sharing, but 401k, Roth 401k, etc.

Here's my current code:

Sub ProfitSharing()


Dim rng As Range
Dim rng2 As Range
Dim i As Integer
Dim finalrow As Integer


finalrow = Sheets("Table 1").Range("A100").End(xlUp).Row


For Each rng In Sheets("Sheet1").Range("A1:A100")
For Each rng2 In Sheets("Table 1").Range("A1:A100")


If rng = rng2 Then


For i = 4 To finalrow


Sheets("Table 1").Range("A" & i).Select


If ActiveCell = "Profit Sharing" Then


ActiveCell.Offset(0, 6).Copy


rng.Offset(0, 15).PasteSpecial xlPasteFormulasAndNumberFormats


End If


Next


End If


Next


Next


End Sub

 

[tonyyy]

And, if you want to include "Safe Harbor" in this code...

Sub ProfitSharing()

Dim rng As Range
Dim rng2 As Range
Dim i As Integer
Dim finalrow As Integer
Application.ScreenUpdating = False

finalrow = Sheets("Table 1").Range("A100").End(xlUp).Row

For Each rng In Sheets("Sheet1").Range("A1:A10")
    For Each rng2 In Sheets("Table 1").Range("A1:A10")
        If rng = rng2 Then
            For i = rng2.Offset(1, 0).Row To finalrow
                If InStr(Sheets("Table 1").Range("A" & i).Value, ",") = 0 Then
                    If UCase(Sheets("Table 1").Range("A" & i).Value) = UCase("Profit Sharing") Then
                        Sheets("Table 1").Range("A" & i).Offset(0, 6).Copy Destination:=rng.Offset(0, 15)
                    End If
                    
                    If UCase(Sheets("Table 1").Range("A" & i).Value) = UCase("Safe Harbor") Then
                        Sheets("Table 1").Range("A" & i).Offset(0, 6).Copy Destination:=rng.Offset(0, 17)
                    End If
                Else
                    Exit For
                End If
            Next
        End If
    Next
Next

Application.ScreenUpdating = True
End Sub

You can repeat the following construct, replacing "Safe Harbor" with "401k" or some other category and changing the offset column...

If UCase(Sheets("Table 1").Range("A" & i).Value) = UCase("[COLOR=#ff0000]Safe Harbor[/COLOR]") Then
     Sheets("Table 1").Range("A" & i).Offset(0, 6).Copy Destination:=rng.Offset(0, [COLOR=#ff0000]17[/COLOR])
End If

 

[wmehar]

Sub ProfitSharing()

Option Compare Text


Dim rng As Range
Dim rng2 As Range
Dim i As Integer
Dim finalrow As Integer
Application.ScreenUpdating = False




finalrow = Sheets("Table 1").Range("A100").End(xlUp).Row


For Each rng In Sheets("Sheet1").Range("A1:A100")
    For Each rng2 In Sheets("Table 1").Range("A1:A100")
        If rng = rng2 Then
            For i = rng2.Offset(1, 0).Row To finalrow
                If InStr(Sheets("Table 1").Range("A" & i).Value, ",") > 0 Then
                i = i + 100
                ElseIf (Sheets("Table 1").Range("A" & i).Value) = ("Profit Sharing") Or (Sheets("Table 1").Range("A" & i).Value) = ("Employer Contributio") Or (Sheets("Table 1").Range("A" & i).Value) = ("REGULAR ER CONTRIB") Or (Sheets("Table 1").Range("A" & i).Value) = ("EMPLOYER CONTRIB") Or (Sheets("Table 1").Range("A" & i).Value) = ("Er Profit Sharing") Or (Sheets("Table 1").Range("A" & i).Value) = ("PROFIT SHARING MSSB") Or (Sheets("Table 1").Range("A" & i).Value) = ("PROFIT SHARING ACCT") Or (Sheets("Table 1").Range("A" & i).Value) = ("ER Contribution") Or (Sheets("Table 1").Range("A" & i).Value) = ("EMPLOYER ACCT") Then
                    Sheets("Table 1").Range("A" & i).Offset(0, 6).Copy
                    rng.Offset(0, 15).PasteSpecial xlPasteFormulasAndNumberFormats
                    Exit For
                End If
            Next
        End If
    Next
Next
Application.ScreenUpdating = True
Call SafeHarbor
End Sub


Sub SafeHarbor()


Dim rng As Range
Dim rng2 As Range
Dim i As Integer
Dim finalrow As Integer
Application.ScreenUpdating = False


finalrow = Sheets("Table 1").Range("A100").End(xlUp).Row


For Each rng In Sheets("Sheet1").Range("A1:A100")
    For Each rng2 In Sheets("Table 1").Range("A1:A100")
        If rng = rng2 Then
            For i = rng2.Offset(1, 0).Row To finalrow
                If InStr(Sheets("Table 1").Range("A" & i).Value, ",") > 0 Then
                i = i + 10
                ElseIf (Sheets("Table 1").Range("A" & i).Value) = ("Safe Harbor failsafe") Or (Sheets("Table 1").Range("A" & i).Value) = ("Safe Harbor") Or (Sheets("Table 1").Range("A" & i).Value) = ("SAFE HARBOR NON-ELEC") Or (Sheets("Table 1").Range("A" & i).Value) = ("SAFE HARBOR NEC") Or (Sheets("Table 1").Range("A" & i).Value) = ("SH NON-ELECTIVE") Or (Sheets("Table 1").Range("A" & i).Value) = ("SAFE HARBOR NON-EL") Or (Sheets("Table 1").Range("A" & i).Value) = ("SAFE HARBOR NON ELEC") Or (Sheets("Table 1").Range("A" & i).Value) = ("SH NON-ELECT MSSB") Or (Sheets("Table 1").Range("A" & i).Value) = ("SAFE HARBOR NE") Or (Sheets("Table 1").Range("A" & i).Value) = ("SAFE HARBOR ACCT") Or (Sheets("Table 1").Range("A" & i).Value) = ("SAFE HARBOR CONTRIB") Then
                    Sheets("Table 1").Range("A" & i).Offset(0, 6).Copy
                    rng.Offset(0, 17).PasteSpecial xlPasteFormulasAndNumberFormats
                    Exit For
                End If
            Next
        End If
    Next
Next
Application.ScreenUpdating = True
Call ElectiveDeferrals
End Sub


Sub ElectiveDeferrals()


Dim rng As Range
Dim rng2 As Range
Dim i As Integer
Dim finalrow As Integer
Application.ScreenUpdating = False


finalrow = Sheets("Table 1").Range("A100").End(xlUp).Row


For Each rng In Sheets("Sheet1").Range("A1:A100")
    For Each rng2 In Sheets("Table 1").Range("A1:A100")
        If rng = rng2 Then
            For i = rng2.Offset(1, 0).Row To finalrow
[B]                If InStr(Sheets("Table 1").Range("A" & i).Value, ",") > 0 Then[/B]
[B]                i = i + 100[/B]
                ElseIf (Sheets("Table 1").Range("A" & i).Value) = ("401(k) Deferrals") Or (Sheets("Table 1").Range("A" & i).Value) = ("IRC401(k) Deferral") Or (Sheets("Table 1").Range("A" & i).Value) = ("401(k) DEFERRAL") Or (Sheets("Table 1").Range("A" & i).Value) = ("DEFERRALS") Or (Sheets("Table 1").Range("A" & i).Value) = ("SALARY DEFERRALS") Or (Sheets("Table 1").Range("A" & i).Value) = ("Salary Deferral") Then
                    Sheets("Table 1").Range("A" & i).Offset(0, 6).Copy
                    rng.Offset(0, 20).PasteSpecial xlPasteFormulasAndNumberFormats
                    Exit For
                End If
            Next
        End If
    Next
Next
Application.ScreenUpdating = True
End Sub


End Sub

I ended up playing around with your first suggestion, I have a word bank of varying spellings of sources in my account balance import sheets, I threw in the bolded code and it works magically and I have no idea why. It does it perfectly, and It could not have been done without your help.

The next three lines extrapolate to other sources, I'm going to add in 5 more sources with their own word banks and do a call at the end to make sure to run them all.

 

[tonyyy]

If this approach works for you, great, that's what matters. Glad I was able to help.

Cheers,

tonyyy