Modify script to provide totals that isnt always in the same location

Sparkey89

New Member
Joined
Jul 29, 2022
Messages
2
Office Version
  1. 365
Platform
  1. Windows
I have a VBA script that I would like to add some total funtions to. It was originally done by a third party and also is in spanish. I speak neither spanish or VBA. If my terminology or anything is terrible please be patient with me as I dont do much coding. I typically make minor alterations to existing code to better suit my needs. I've been able to get it to add new column titles and the information but figuring out how to total it up has me lost.

A short description of the code is that I open the sheet with the Macro in it. Run the macro which asks me to find the sheet I'm working with and then it goes down column A and finds the block name and then copies information from a database into that row. After doing that for all of the blocks then it will organize them by color.

The number/location/Order of the columns will always stay the same but the number of rows will always be different. One constant is that at the very bottom of the sheet in column B will always be "Grand Total". My thought was to script a way at the end to find the cell with "Grand Total", move 12 cells over to column N, Input "Gasket Total" (in bold, and resize column to fit text), move one cell over and input a formula giving a total for column O. Then move one row down, one column left and input "Gasket Boxes" (in bold). Move one cell over and take the gasket total, divide by 200, and round up to the nearest whole number. The end goal just being that the total quantity of gasket material is listed along with how many boxes that ends up being rounded up.

Attached are two images. One showing how the code completes currently and one showing what I'm trying to achieve.

Attached is most of the code. Its at least the part i've been modifying to add the new gasket columns. If theres any questions about it I can do my best to answer but I did not write it nor do I know much about VBA. Please let me know if I need to provide any additional sheets (like the database), sample sheet, ect. If you provide just the additional code please also tell me where I would need to insert the code for it to function. I literally have a day at best of working with VBA and it gets over my head quickly.

VBA Code:
Private Sub CommandButton1_Click()
'
' Import
'
' BOTON PARA CARGAR LOS DATOS EN EL ACTUAL LIBRO PROVENIENTES DE OTROS LIBROS EXTERNOS
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim WorkBookOrigen, WorkbookDestino As Workbook
Dim HojaOrigen As Excel.Worksheet, _
    HojaDestino As Excel.Worksheet, _
    RutaO As String
Dim i, j, ColoNum, BF, BI, r As Integer
Dim HojaMain As Excel.Worksheet, _
    HojaInsultechColorations As Excel.Worksheet
    
Sheets("InsultechColorations").Visible = True
'############################################
' Aquí se coloca la información que se
' almacena en "18-0070"
'############################################

'Se reconoce el libro destino como el actual
Set WorkbookDestino = ActiveWorkbook

' Se limpia el contenido previo
Sheets("Main").Select
Cells.Delete 'o ClearContents
Range("A1").Select
RutaO = ActiveWorkbook.Path & "\" & ComboBox1.Value
Set WorkBookOrigen = Workbooks.Open(RutaO)

WorkBookOrigen.Worksheets(1).Range("A:AZ").Copy

' Se exporta el contenido de la Base de datos
Set HojaDestino = WorkbookDestino.Worksheets("Main")

WorkbookDestino.Activate
HojaDestino.Select
HojaDestino.Range("A1").Select
ActiveSheet.Paste
Range("A2").Select
ActiveCell.FormulaR1C1 = "Insultech Unit Counts"

Range("N4").Select
ActiveCell.FormulaR1C1 = "LF Gasket/Unit"
Range("O4").Select
ActiveCell.FormulaR1C1 = "LF Gasket/Shape"

Columns("A:O").EntireColumn.AutoFit
Rows("1:5").Select
Selection.Font.Bold = True

WorkBookOrigen.Save
WorkBookOrigen.Close
Range("A1").Select


'############################################
' Aquí se coloca la información que se
' almacena "InsultechColorations"
'############################################

' Se limpia el contenido previo
Sheets("InsultechColorations").Select
Cells.Delete
Range("A1").Select
RutaO = ActiveWorkbook.Path & "\" & "InsultechColorations"
Set WorkBookOrigen = Workbooks.Open(RutaO)

WorkBookOrigen.Worksheets(1).Range("A:AZ").Copy

' Se exporta el contenido de la Base de datos
Set HojaDestino = WorkbookDestino.Worksheets("InsultechColorations")

WorkbookDestino.Activate
HojaDestino.Select
HojaDestino.Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteAllUsingSourceTheme, Operation:=xlNone _
    , SkipBlanks:=False, Transpose:=False
    
Sheets("InsultechColorations").Select
Range("L2:S4").Select
Selection.Copy
Sheets("Main").Select
Range("F1").Select
ActiveSheet.Paste

WorkBookOrigen.Save
WorkBookOrigen.Close

'##############################################
'############ Coincide y copia ################
'##############################################
   
Set HojaMain = ActiveWorkbook.Worksheets("Main")

Set HojaInsultechColorations = ActiveWorkbook.Worksheets("InsultechColorations")

HojaInsultechColorations.Activate
Range("B2").End(xlDown).Select
ColoNum = ActiveCell.Row

HojaMain.Activate
Range("A6").Select
BI = ActiveCell.Row
Range("A6").End(xlDown).Select
BF = ActiveCell.Row

'inicio for

Do While Range("A" & BI).Value <> ""
    r = 0

    For i = BI To BF
        For j = 2 To ColoNum
            If HojaMain.Range("A" & i).Value = HojaInsultechColorations.Range("B" & j).Value Then
                HojaInsultechColorations.Range("A" & j & ":K" & j).Copy
                HojaMain.Range("E" & i).Select
                Selection.PasteSpecial Paste:=xlPasteAllUsingSourceTheme, Operation:=xlNone _
                     , SkipBlanks:=False, Transpose:=False
                r = 1
            End If
        Next j
    Next i
    
    '#############################################################
    '# Ordenar por colores las coincidencias de los bloques I y II
    '# Hoja AUX: fue creada para ordenar y luego copiar la info
    '#           en la hoja main, permanecerá oculta.
    '#############################################################
    If r = 1 Then
    
        Sheets("AUX").Visible = True
        Sheets("AUX").Select
        Cells.Select
        Selection.Delete Shift:=xlUp
        
        Sheets("Main").Select
        Range("A" & BI & ":O" & BF).Select
        'Selection.MergeCells = False
        Selection.UnMerge
        Selection.Copy
        Sheets("AUX").Select
        ActiveSheet.Paste
        Application.CutCopyMode = False
        Selection.Borders(xlDiagonalDown).LineStyle = xlNone
        Selection.Borders(xlDiagonalUp).LineStyle = xlNone
        Selection.Borders(xlEdgeLeft).LineStyle = xlNone
        Selection.Borders(xlEdgeTop).LineStyle = xlNone
        Selection.Borders(xlEdgeBottom).LineStyle = xlNone
        Selection.Borders(xlEdgeRight).LineStyle = xlNone
        Selection.Borders(xlInsideVertical).LineStyle = xlNone
        Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
        
        Columns("A:O").Select
        ActiveWorkbook.Worksheets("AUX").Sort.SortFields.Clear
        
        ActiveWorkbook.Worksheets("AUX").Sort.SortFields.Add Key:=Range("G1:G1000"), _
            SortOn:=xlSortOnCellColor, Order:=xlDescending, DataOption:=xlSortNormal
        ActiveWorkbook.Worksheets("AUX").Sort.SortFields.Add(Range("G1:G1000"), _
            xlSortOnCellColor, xlAscending, , xlSortNormal).SortOnValue.Color = RGB(255, _
            255, 255)
        ActiveWorkbook.Worksheets("AUX").Sort.SortFields.Add(Range("G1:G1000"), _
            xlSortOnCellColor, xlAscending, , xlSortNormal).SortOnValue.Color = RGB(255, _
            230, 153)
        ActiveWorkbook.Worksheets("AUX").Sort.SortFields.Add(Range("G1:G1000"), _
            xlSortOnCellColor, xlAscending, , xlSortNormal).SortOnValue.Color = RGB(169, _
            208, 142)
        ActiveWorkbook.Worksheets("AUX").Sort.SortFields.Add(Range("G1:G1000"), _
            xlSortOnCellColor, xlDescending, , xlSortNormal).SortOnValue.Color = RGB(217, _
            217, 217)
        With ActiveWorkbook.Worksheets("AUX").Sort
            .SetRange Range("A1:O1000")
            .Header = xlGuess
            .MatchCase = False
            .Orientation = xlTopToBottom
            .SortMethod = xlPinYin
            .Apply
        End With
        DeltaB = BF - BI + 1
        
        Range("A1:O" & DeltaB).Select
        Selection.Copy
        
        Sheets("Main").Select
        Range("A" & BI).Select
        Selection.PasteSpecial Paste:=xlPasteAllUsingSourceTheme, Operation:=xlNone _
                     , SkipBlanks:=False, Transpose:=False
        Application.CutCopyMode = False
    
    
        Range("F" & BI).End(xlDown).Select
        AsigB = ActiveCell.Row
        
        Range("F" & BI & ":M" & AsigB).Select
        Selection.Borders(xlDiagonalDown).LineStyle = xlNone
        Selection.Borders(xlDiagonalUp).LineStyle = xlNone
        With Selection.Borders(xlEdgeLeft)
            .LineStyle = xlContinuous
            .ColorIndex = 0
            .TintAndShade = 0
            .Weight = xlMedium
        End With
        With Selection.Borders(xlEdgeTop)
            .LineStyle = xlContinuous
            .ColorIndex = 0
            .TintAndShade = 0
            .Weight = xlMedium
        End With
        With Selection.Borders(xlEdgeBottom)
            .LineStyle = xlContinuous
            .ColorIndex = 0
            .TintAndShade = 0
            .Weight = xlMedium
        End With
        With Selection.Borders(xlEdgeRight)
            .LineStyle = xlContinuous
            .ColorIndex = 0
            .TintAndShade = 0
            .Weight = xlMedium
        End With
        With Selection.Borders(xlInsideVertical)
            .LineStyle = xlContinuous
            .ColorIndex = 0
            .TintAndShade = 0
            .Weight = xlMedium
        End With
        With Selection.Borders(xlInsideHorizontal)
            .LineStyle = xlContinuous
            .ColorIndex = 0
            .TintAndShade = 0
            .Weight = xlMedium
        End With
        Range("G" & BI & ":M" & AsigB).Select
        Selection.Merge True
    End If
    
    HojaMain.Activate
    Range("A" & BF + 4).Select
    BI = ActiveCell.Row
    Range("A" & BI).End(xlDown).Select
    BF = ActiveCell.Row

Loop

'#######################################################
Range("A1").Select

Sheets("AUX").Visible = False
Sheets("InsultechColorations").Visible = False
MsgBox "Ready. The corresponding 'Insultech Coloration' was assigned to each record.", vbInformation
Application.DisplayAlerts = True
Application.ScreenUpdating = True

Unload Me
End Sub

Private Sub CommandButton1_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
CommandButton1.BackColor = &HFFFF80
CommandButton1.Font.Bold = True
CommandButton1.Font.Size = 18
End Sub

Private Sub UserForm_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
CommandButton1.BackColor = &H8000000F
CommandButton1.Font.Bold = False
CommandButton1.Font.Size = 12
End Sub

Private Sub UserForm_Initialize()
ComboBox1.RowSource = "LISTA"
End Sub


Thank you all very much.
 

Attachments

  • What is produced.PNG
    What is produced.PNG
    99.4 KB · Views: 27
  • Excel Goal.PNG
    Excel Goal.PNG
    100.7 KB · Views: 23

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.
Got it figured out

VBA Code:
Sub Find()

Dim FoundItem As Range

Set FoundItem = Range("B:B").Find("Grand Total")

FoundItem.Offset(0, 11) = "Gasket Total"
FoundItem.Offset(0, 12) = "=sum(O6:O5000)"
FoundItem.Offset(1, 11) = "Boxes of Gasket"
FoundItem.Offset(1, 12) = "=ROUNDUP((@INDIRECT(ADDRESS(ROW()-1,COLUMN()))/200),0)"

FoundItem.Offset(0, 11).Font.Bold = True
FoundItem.Offset(1, 11).Font.Bold = True

Cells.Columns.AutoFit

End Sub

I just added it to the end after deleting the "sub" and "end sub". Its not ideal as its one column to the left of where I would like it to be but I was beyond lost while trying to create a dynamic column sum.
 
Upvote 0
Solution
Welcome to the MrExcel Message Board!
And thanks for sharing your solution with future readers.

The following modification could help with the desired column since the underlying reason is using a wide range to get the sum on column O.
(Note: I didn't change your approach and the method you used but only set the address used in the SUM function dynamically by using the Grand Total cell's row value. This way, you don't have to use O5000.

VBA Code:
FoundItem.Offset(0, 12) = "Gasket Total"
FoundItem.Offset(0, 13) = "=sum(O6:O" & (FoundItem.Row - 1) & ")"
FoundItem.Offset(1, 12) = "Boxes of Gasket"
FoundItem.Offset(1, 13) = "=ROUNDUP((@INDIRECT(ADDRESS(ROW()-1,COLUMN()))/200),0)"

FoundItem.Offset(0, 12).Font.Bold = True
FoundItem.Offset(1, 12).Font.Bold = True
 
Upvote 0

Forum statistics

Threads
1,223,886
Messages
6,175,198
Members
452,617
Latest member
Narendra Babu D

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