Macro to copy numbers & format table across different sheets

[mikiel111]

I need 2 what i`m guessing are simple macros

Part of what I needed was done below but it did not work once i copied the macro into my file (prob my fault?) & it did not fulfil my requirements exactly.
(I`m greatful to the person who did it)

I need the following (Im not managing to record them myself)

Macro 1
Copy cells from sheet Nutri checker to sheet Sheet2, (table below showing what`s to be copied & where). The Dashboard in Nutri Checker is a search. I search the item I want & its details are filled. I want those copied to Sheet2. I might then find another item & also have it`s details copied to sheet2 adjacent to previously copied details. The macro has to handle 1) single items being removed (e.g. I remove screw with all its entries copied). So after removing screw the next item I copy should go into it`s place and 2) the entire thing except for whats written in column A (will always be there) (e.g. I`ll remove torch, screw and everything else copied in) start copying the items in again starting from column B. The cell background for cells B9 & B10 in Sheet2 should be off white.

I`m not sure if this can be handled but if I have copied 3 items and the middle one is removed. If it is too hard to handle I can avoid doing it or re-arrange the cells so as to not break the macro

Macro 2
The sum of each row (irrespective of how many items are added) totalled as shown in the screenshot, with black background, white text and totals written in at the bottom.

Sheet: Nutri Checker	Sheet: Sheet2
E1	B5
E2	B6
E3	B7
E4	B8
E5	B9
A4	B10

Sub CopyItems()
    
    Dim ws1 As Worksheet, ws2 As Worksheet
    Dim NextColumn As Long
    
    Set ws1 = Sheets("Sheet1")
    Set ws2 = Sheets("Sheet2")
    
    'last used column
    NextColumn = ws1.Cells(5, Columns.Count).End(xlToLeft).Column - 1
    
    'insert column with formatting from the left
    If ws1.Cells(5, NextColumn) <> Empty Then
        ws1.Columns(NextColumn + 1).Rows("5:10").Insert xlShiftToRight, xlFormatFromLeftOrAbove
        NextColumn = NextColumn + 1
    End If
    
    'copy values
    ws1.Cells(10, NextColumn).Value = ws2.Range("A4").Value
    ws1.Cells(9, NextColumn).Value = ws2.Range("E1").Value
    ws1.Cells(5, NextColumn).Resize(4, 1).Value = ws2.Range("E2:E5").Value
    
    'total formulas
    ws1.Cells(5, NextColumn + 1).Resize(4, 1).Formula = "=SUM(RC2:RC[-1])"
    
End Sub

*Macro to copy numbers & format table across different sheets

 

[sijpie]

I hope this is still relevant.

But this macro will copy the item into the table on Sheet2. I will add the macro to delete an item later. Read the comments starting with <<<< to see if you need to adjust anything

Option Explicit

Sub AddItem()
    Dim vOut As Variant
    Dim lR As Long, lC As Long, UB1 As Long, UB2 As Long
    Dim wsNC As Worksheet, wsS2 As Worksheet
    Dim rOut As Range, rItm As Range, rVal As Range
    
    Set wsNC = Sheets("Nutri Checker")  '<<<<  Modify name as required for input selection sheet
    Set wsS2 = Sheets("Sheet2")         '<<<<  Modify name as required for output sheet
    
    Set rOut = wsS2.Range("A5")         '<<<<  Modify starting cell of Sheet2 as required
    
    Set rItm = wsNC.Range("A5")         '<<<<  Modify item cell as required
    Set rVal = wsNC.Range("E1")         '<<<<  Modify 1st cell with values to be copied as required
    
    
    
        'insert a column in column B for the new data
    rOut.Offset(0, 1).Resize(6, 1).Insert
        
        'add some dummy text to make it one contiguous region
    rOut.Offset(0, 1).Value = "xx"
    Format1stColumn rOut.Offset(0, 1)
    lC = rOut.CurrentRegion.Columns.Count
    If lC > 3 Then
        'there were more entries, take away grey shading of previous column B
        Format2ndColumn rOut.Offset(0, 2)
    End If
    'the macro works with arrays as these are blindingly fast, no matter how large the array is
    ReDim vOut(1 To 6, 1 To 1)
    'create totals formulas for the totals range into the array
    For lR = 1 To 6
        vOut(lR, 1) = "=sum(rc[-" & lC - 2 & "]:rc[-1])"    'Use RC notation as it is easy
    Next lR
    ' dump into totals column
    rOut.Offset(0, lC - 1).Resize(6, 1).Formula = vOut
    
    'now put the selected item values in the output array
    For lR = 1 To 4
        vOut(lR, 1) = rVal.Offset(lR, 0).Value
        
    Next lR
    vOut(5, 1) = rVal.Value
    vOut(6, 1) = rItm.Value
    'dump into column B
    rOut.Offset(0, 1).Resize(6, 1).Value = vOut
End Sub


Sub Format1stColumn(r1stCell As Range)
    
    With r1stCell.Resize(4, 1)  'top four cells (B5:B8), clear fill, black font
        With .Interior
            .Pattern = xlNone
            .TintAndShade = 0
            .PatternTintAndShade = 0
        End With
        With .Font
            .ColorIndex = xlAutomatic
            .TintAndShade = 0
            .Bold = False
        End With
    End With
    With r1stCell.Offset(4, 0).Resize(2, 1) 'bottom two cells (B9:B10), light grey fill
        With .Interior
            .Pattern = xlSolid
            .PatternColorIndex = xlAutomatic
            .ThemeColor = xlThemeColorDark1
            .TintAndShade = -4.99893185216834E-02
            .PatternTintAndShade = 0
        End With
        With .Font
            .ColorIndex = xlAutomatic
            .TintAndShade = 0
            .Bold = False
        End With
    End With

End Sub

Sub Format2ndColumn(r1stCell As Range)

    With r1stCell.Offset(4, 0).Resize(2, 1) 'bottom two cells (C9:C10),clear fill
        With .Interior
            .Pattern = xlNone
            .TintAndShade = 0
            .PatternTintAndShade = 0
        End With
    End With

End Sub

 

[sijpie]

Here is the complete macro, with a few improvements on what I posted yesterday.

I am assuming the remove item button is also run from the front sheet and the item in cell A4 is to be removed.

Option Explicit

Sub AddItem()
    Dim vOut As Variant
    Dim lR As Long, lC As Long, UB1 As Long, UB2 As Long
    Dim wsNC As Worksheet, wsS2 As Worksheet
    Dim rOut As Range, rItm As Range, rVal As Range
    
    Set wsNC = Sheets("Nutri Checker")  '<<<<  Modify name as required for input selection sheet
    Set wsS2 = Sheets("Sheet2")         '<<<<  Modify name as required for output sheet
    
    Set rOut = wsS2.Range("A5")         '<<<<  Modify starting cell of Sheet2 as required
    
    Set rItm = wsNC.Range("A4")         '<<<<  Modify item cell as required
    Set rVal = wsNC.Range("E1")         '<<<<  Modify 1st cell with values to be copied as required
    
    
    
        'insert a column in column B for the new data
    rOut.Offset(0, 1).Resize(6, 1).Insert
        
        'add some dummy text to make it one contiguous region
    rOut.Offset(0, 1).Value = "xx"
    Format1stColumn rOut.Offset(0, 1)
    lC = rOut.CurrentRegion.Columns.Count
    If lC > 3 Then
        'there were more entries, take away grey shading of previous column B
        Format2ndColumn rOut.Offset(0, 2)
    End If
    'the macro works with arrays as these are blindingly fast, no matter how large the array is
    ReDim vOut(1 To 4, 1 To 1)
    'create totals formulas for the totals range into the array
    For lR = 1 To 4
        vOut(lR, 1) = "=sum(rc[-" & lC - 2 & "]:rc[-1])"    'Use RC notation as it is easy
    Next lR
    ' dump into totals column
    rOut.Offset(0, lC - 1).Resize(4, 1).Formula = vOut
    
    'now put the selected item values in the output array
    For lR = 1 To 4
        vOut(lR, 1) = rVal.Offset(lR, 0).Value
        
    Next lR
    vOut(5, 1) = rVal.Value
    vOut(6, 1) = rItm.Value
    'dump into column B
    rOut.Offset(0, 1).Resize(6, 1).Value = vOut
    
    'cleanup
    Set wsNC = Nothing
    Set wsS2 = Nothing
    Set rOut = Nothing
    Set rVal = Nothing
End Sub

Sub RemoveItem()
    Dim vOut As Variant
    Dim lR As Long, lC As Long, UB1 As Long, UB2 As Long
    Dim wsNC As Worksheet, wsS2 As Worksheet
    Dim rOut As Range, rItm As Range, rFnd As Range
    
    Set wsNC = Sheets("Nutri Checker")  '<<<<  Modify name as required for input selection sheet
    Set wsS2 = Sheets("Sheet2")         '<<<<  Modify name as required for output sheet
    
    Set rOut = wsS2.Range("A5")  '<<<<  Modify starting cell of Sheet2 as required
    UB2 = rOut.CurrentRegion.Columns.Count
    
    Set rItm = wsNC.Range("A4")         '<<<<  Modify item cell as required
    
    Set rFnd = rOut.CurrentRegion.Find(what:=rItm.Value, lookat:=xlWhole)
    If rFnd Is Nothing Then
        MsgBox prompt:="Item " & rItm & " has not been found in list", _
               Title:="Error", Buttons:=vbExclamation
        Exit Sub
    End If
    lC = rFnd.Column
    
    'select this column and delete
    rFnd.Offset(-5, 0).Resize(6, 1).Delete shift:=xlToLeft
    
    'set colour for 1st column (unless, all columns deleted and only totals column remains)
    If lC = 2 And UB2 > 3 Then Format1stColumn rOut.Offset(0, 1)
    
        
    'cleanup
    Set wsNC = Nothing
    Set wsS2 = Nothing
    Set rOut = Nothing
End Sub


Sub Format1stColumn(r1stCell As Range)
    
    With r1stCell.Resize(4, 1)  'top four cells (B5:B8), clear fill, black font
        With .Interior
            .Pattern = xlNone
            .TintAndShade = 0
            .PatternTintAndShade = 0
        End With
        With .Font
            .ColorIndex = xlAutomatic
            .TintAndShade = 0
            .Bold = False
        End With
    End With
    With r1stCell.Offset(4, 0).Resize(2, 1) 'bottom two cells (B9:B10), light grey fill
        With .Interior
            .Pattern = xlSolid
            .PatternColorIndex = xlAutomatic
            .ThemeColor = xlThemeColorDark1
            .TintAndShade = -4.99893185216834E-02
            .PatternTintAndShade = 0
        End With
        With .Font
            .ColorIndex = xlAutomatic
            .TintAndShade = 0
            .Bold = False
        End With
    End With

End Sub

Sub Format2ndColumn(r1stCell As Range)

    With r1stCell.Offset(4, 0).Resize(2, 1) 'bottom two cells (C9:C10),clear fill
        With .Interior
            .Pattern = xlNone
            .TintAndShade = 0
            .PatternTintAndShade = 0
        End With
    End With

End Sub