Macro Help with Pasting Formula Values

[carden2]

Right now the macro will find the high value in column E and subtract it with a value in Column B2-B7 until each cell from B2-B7 reaches 0. I wanted to paste these subtractions into Column G. I also wanted to paste the categories it came from so I could use them for the 2nd part of my project.

I have tired numerous different things but can't get anything to seem to record each subtraction in column G. I was going to paste the category for each subtraction also in columns H and I.

So for instance a credit card subtracting from textbooks would show the amount in G that was subtracted then in H say credit card and I would say textbooks.

Any help would be appreciated.

Thanks

[tigeravatar]

carden2,

Attached is a modified version of your posted workbook.
I removed the existing macros and replaced them with this one:

Sub tgr()
    
    Dim rngB As Range
    Dim rngE As Range
    Dim BCell As Range
    Dim ECell As Range
    Dim arrData(1 To 65000, 1 To 6) As Variant
    Dim DataIndex As Long
    Dim strCat1 As String
    Dim strCat2 As String
    Dim dCat1 As Double
    Dim dCat2 As Double
    Dim dMax As Double
    
    Set rngB = Range("B2", Range("B2").End(xlDown))
    Set rngE = Range("E2", Range("E2").End(xlDown))
    
    For Each BCell In rngB.Cells
        Do While BCell.Value > 0
            dMax = 0
            dMax = Evaluate("Max(If(" & rngE.Address & "<>0," & rngE.Address & "))")
            If dMax = 0 Then Exit Do
            Set ECell = rngE.Find(dMax, , xlFormulas, xlWhole)
            Select Case (dMax > BCell.Value)
                Case True:  strCat1 = ECell.Offset(, -1).Text
                            strCat2 = BCell.Offset(, -1).Text
                            dCat1 = ECell.Value
                            dCat2 = BCell.Value
                            ECell.Value = ECell.Value - BCell.Value
                            BCell.Value = 0
                            
                Case Else:  strCat1 = BCell.Offset(, -1).Text
                            strCat2 = ECell.Offset(, -1).Text
                            dCat1 = BCell.Value
                            dCat2 = ECell.Value
                            BCell.Value = BCell.Value - ECell.Value
                            ECell.Value = 0
            End Select
            
            DataIndex = DataIndex + 1
            arrData(DataIndex, 1) = strCat1
            arrData(DataIndex, 2) = dCat1
            arrData(DataIndex, 3) = dCat1 - dCat2
            arrData(DataIndex, 4) = strCat2
            arrData(DataIndex, 5) = dCat2
            arrData(DataIndex, 6) = 0
            
        Loop
    Next BCell
    
    If DataIndex > 0 Then Range("G2").Resize(DataIndex, UBound(arrData, 2)).Value = arrData
    
    Set rngB = Nothing
    Set rngE = Nothing
    Set BCell = Nothing
    Set ECell = Nothing
    Erase arrData
    
End Sub

Is something like that what you're looking for?

[carden2]

Wow thanks. It's really close. I changed the range to B3-B7 I want to leave cash deposits. The categories seem to get mixed up some as well. The categories in column A should show in column G only and column D categories in column J only. I think with that change I can figure out the difference in each subtraction so each subtraction made should all be in the same row.

like the category A/before amount/after amount then category D/before amount/after amount

[tigeravatar]

carden2,

Updated code and attachment:

Sub tgr()
    
    Dim rngB As Range
    Dim rngE As Range
    Dim BCell As Range
    Dim ECell As Range
    Dim arrData(1 To 65000, 1 To 6) As Variant
    Dim DataIndex As Long
    Dim dMax As Double
    Dim bNewMax As Boolean
    
    Set rngB = Range("B3", Range("B2").End(xlDown))
    Set rngE = Range("E2", Range("E2").End(xlDown))
    
    For Each BCell In rngB.Cells
        Do While BCell.Value > 0
            bNewMax = (ECell Is Nothing)
            If bNewMax = False Then bNewMax = (ECell.Value2 = 0)
            If bNewMax = True Then
                dMax = 0
                dMax = Evaluate("Max(If(" & rngE.Address & "<>0," & rngE.Address & "))")
                If dMax = 0 Then Exit Do
                Set ECell = rngE.Find(dMax, , xlFormulas, xlWhole)
            End If
            dMax = WorksheetFunction.Min(ECell.Value2, BCell.Value2)
            
            DataIndex = DataIndex + 1
            arrData(DataIndex, 1) = BCell.Offset(, -1).Text
            arrData(DataIndex, 2) = BCell.Value2
            arrData(DataIndex, 3) = BCell.Value2 - dMax
            arrData(DataIndex, 4) = ECell.Offset(, -1).Text
            arrData(DataIndex, 5) = ECell.Value2
            arrData(DataIndex, 6) = ECell.Value2 - dMax
            
            dMax = arrData(DataIndex, 6)
            BCell.Value = arrData(DataIndex, 3)
            ECell.Value = arrData(DataIndex, 6)
        Loop
    Next BCell
    
    If DataIndex > 0 Then Range("G2").Resize(DataIndex, UBound(arrData, 2)).Value = arrData
    
    Set rngB = Nothing
    Set rngE = Nothing
    Set BCell = Nothing
    Set ECell = Nothing
    Erase arrData
    
End Sub

[carden2]

Perfect. Thank you very much for the help.

I was wondering if you could explain your code a little to me if you would. Are you making a data array of numbers?

[tigeravatar]

Same code with comments. Hopefully this helps explain what is going on and why:

Sub tgr()
    
    'Declare variables
    Dim rngB As Range                           'The cells in column B to be looped through
    Dim rngE As Range                           'The cells in column E to find the max E value
    Dim BCell As Range                          'Variable used to loop through rngB
    Dim ECell As Range                          'Variable used to identify the cell containing the max value in rngE
    Dim arrData(1 To 65000, 1 To 6) As Variant  'Array to build subtraction history
    Dim DataIndex As Long                       'Variable used to determine location in arrData
    Dim dMax As Double                          'Variable used to find the max value in rngE
    Dim bNewMax As Boolean                      'Boolean value used to determine if a new max value in rngE is necessary
    
    'Define rngB and rngE
    Set rngB = Range("B3", Range("B2").End(xlDown))
    Set rngE = Range("E2", Range("E2").End(xlDown))
    
    'Initiate loop for rngB
    For Each BCell In rngB.Cells
        
        'Initiate loop for while BCell is greater than 0
        Do While BCell.Value > 0
            
            'Check if a max value has been identified yet (necessary for first iteration)
            bNewMax = (ECell Is Nothing)
            
            'If a max value has already been identified, make sure that cell is not yet 0
            If bNewMax = False Then bNewMax = (ECell.Value2 = 0)
            
            'Max value has either not been identified, or that max value is now 0
            'So a new max value is needed
            If bNewMax = True Then
                dMax = 0    'Reset dMax variable
                
                'Use dMax to find the max value remaining in rngE
                dMax = Evaluate("Max(If(" & rngE.Address & "<>0," & rngE.Address & "))")
                If dMax = 0 Then Exit Do    'If the max value in rngE is 0, there are no more values to subtract
                
                'Assign ECell to the location of dMax, because that cell is the new max value in rngE
                Set ECell = rngE.Find(dMax, , xlFormulas, xlWhole)
            End If
            
            'Determine if ECell or BCell is larger
            dMax = WorksheetFunction.Min(ECell.Value2, BCell.Value2)
            
            'Increase position in array
            DataIndex = DataIndex + 1
            
            'Create array of subtraction history
            arrData(DataIndex, 1) = BCell.Offset(, -1).Text 'Get the BCell Category
            arrData(DataIndex, 2) = BCell.Value2            'Get the BCell Current Value
            arrData(DataIndex, 3) = BCell.Value2 - dMax     'Get the BCell value after subtraction
            arrData(DataIndex, 4) = ECell.Offset(, -1).Text 'Get the ECell Category
            arrData(DataIndex, 5) = ECell.Value2            'Get the ECell Current Value
            arrData(DataIndex, 6) = ECell.Value2 - dMax     'Get the ECell value after subtraction
            
            'Update dMax and cell values
            dMax = arrData(DataIndex, 6)
            BCell.Value = arrData(DataIndex, 3)
            ECell.Value = arrData(DataIndex, 6)
            
        Loop    'Advance loop to bring current BCell to 0
        
    Next BCell  'Advance loop to next BCell
    
    'If there is data in the array, output that data starting in cell G2
    If DataIndex > 0 Then Range("G2").Resize(DataIndex, UBound(arrData, 2)).Value = arrData
    
    'Cleanup
    Set rngB = Nothing
    Set rngE = Nothing
    Set BCell = Nothing
    Set ECell = Nothing
    Erase arrData
    
End Sub

[carden2]

I guess I have one last step. I got the suggestions here implemented and it's working great. I appreciate the documentation as well. This part I wasn't told but I can't figure out as well. I worked on it most the day friday. I need to run the macro and then the remaining amounts left in column E should also go to the side where the account# goes to Credit and the Amount goes to before and after amount. I tried to use the coe I was helped with but had some trouble and I don't want to ruin what has been done so far.

[tigeravatar]

Can you provide a sample of desired results with the new requirements?

[carden2]

Hopefully this makes sense. I attached the most updated version I have that I am working on I filled in the data so you can go to the bookstore tab and click run macro. This does the subtraction code that you wrote. It will run first then after it runs I need it to move the remaining values from column F to column M and the associated Account# with column F would go in Column J under credit.

After that it needs to move any cell in column F that still has a value to the side. There's no subtracting or any more math involved. Just find the cells in column F and move them to column M and move the associated account# with the amount from column E to column J.

After that I click make Bookstore JE and it goes to a tab where it pulls in the information from the bookstore tab so I can eventually create a text file. I need to have description filled in but I think I can get that part. Also the reference numbers will fill in if you put in a reference # in cell B16.

I hope this makes sense.

[tigeravatar]

carden2,

Attached is a modified version of your provided workbook. The code for mathstuff has been updated to the following:

Sub mathstuff()

    Dim rngC As Range
    Dim rngF As Range
    Dim CCell As Range
    Dim FCell As Range
    Dim arrData(1 To 65000, 1 To 6) As Variant
    Dim DataIndex As Long
    Dim dMax As Double
    Dim cNewMax As Boolean
    
    Set rngC = Range("C3", Range("C3").End(xlDown))
    Set rngF = Range("F2", Range("F2").End(xlDown))
    
    For Each CCell In rngC.Cells
        Do While CCell.Value > 0
            cNewMax = (FCell Is Nothing)
            If cNewMax = False Then cNewMax = (FCell.Value2 = 0)
            If cNewMax = True Then
                dMax = 0
                dMax = Evaluate("Max(If(" & rngF.Address & "<>0," & rngF.Address & "))")
                If dMax = 0 Then Exit Do
                Set FCell = rngF.Find(dMax, , xlFormulas, xlWhole)
            End If
            dMax = WorksheetFunction.Min(FCell.Value2, CCell.Value2)
            
            DataIndex = DataIndex + 1
            arrData(DataIndex, 1) = CCell.Offset(, -1).Text
            arrData(DataIndex, 2) = CCell.Value2
            arrData(DataIndex, 3) = CCell.Value2 - dMax
            arrData(DataIndex, 4) = FCell.Offset(, -1).Text
            arrData(DataIndex, 5) = FCell.Value2
            arrData(DataIndex, 6) = FCell.Value2 - dMax
            
            dMax = arrData(DataIndex, 6)
            CCell.Value = arrData(DataIndex, 3)
            FCell.Value = arrData(DataIndex, 6)
        Loop
    Next CCell
    
    If DataIndex > 0 Then Range("G2").Resize(DataIndex, UBound(arrData, 2)).Value = arrData
    
    With Range("F1", Range("F1").End(xlDown))
        .AutoFilter 1, "<>0"
        .Offset(1).Copy Cells(DataIndex + 2, "M")
        .Offset(1, -1).Copy Cells(DataIndex + 2, "J")
        .AutoFilter
    End With
    
    Set rngC = Nothing
    Set rngF = Nothing
    Set CCell = Nothing
    Set FCell = Nothing
    Erase arrData

End Sub

Is that what you're looking for?

[carden2]

Yes that works perfect. Thanks. You've been the most amazing help.

I do have one other question. Why won't access let you begin numbers with 0? It always gives an error and I have to ignore error. Is there a way around this so you can start a number with 0?

[tigeravatar]

Access should let you start numbers with 0, it will just remove leading 0's unless you set a Format, such as 000 which will show the number 1 as 001, the number 12 as 012, and the number 123 as simply 123. However, if you having an issue with Access, you should start a new thread for that question. While I am familiar with Access, I am by no means an expert.

[carden2]

Thanks for the advice I'll have to make the format then. I'll mark the thread as solved.

[carden2]

I am back with one more issue I am needing help with. I finally got it tested out today. I've worked quite a bit on it getting it to reset everything and create a text file. It works great.

The issue I am needing help with now is dealing with negative numbers. A negative number in Column C will just be added to an amount in column F and documented in columns G:M much like when subtracting. The only difference is with the negative numbers the account numbers will be switched. Also a negative amount in column F will be moved to column G,J,M much like the other remaining amounts. The other tricky part about negative numbers is the account numbers will be reversed where the debit# will go in the credit column and vice versa.

I attached my example and any help will be appreciated.

Thanks.

[carden2]

anyone have any ideas on this?

Thanks.

[carden2]

anyone have any suggestions?

Thanks.

[tigeravatar]

With that most recent example file you posted, can you provide a page of the results you're currently getting, and then another page of the results you want to be getting?

[carden2]

Yes give me about 15-20 minutes and I'll it up. Thanks.

[carden2]

Alright I made up some examples Before is what I get now with some explanations in it then the example file shows what it should be getting. I hope this helps I really appreciate the help on this.

[tigeravatar]

Unfortunately I don't have time to go into this very much today, but I'll definitely have a go at it tomorrow, sorry for the delay. Work has been crazy ><

[carden2]

Unfortunately I don't have time to go into this very much today, but I'll definitely have a go at it tomorrow, sorry for the delay. Work has been crazy ><

I know how that is I just appreciate all your effort helping me out with this. I've worked on it for about 2 weeks now it's 1 part to generate a text file while I have almost finished the other part. I look forward to seeing what you come up with. Thanks.

[carden2]

Any ideas on this?

[tigeravatar]

Its been a hard week at work, and my brain is fried

Why don't all the rows have before/after amounts? I see the Debit Account 0400001116, but why is that being pulled? It doesn't have an amount and is after the C column total. This looks like a different enough macro you should probably start a new thread. You'll get more visibility with a new thread also.