Vba code correction in table

[ANTONIO1981]

HI All

in the following file Budget cube & summary 2018 2 testing_to delete.xlsm - Google Drive

I have to create a table based on

1. A list of sites (variable number of sites)
2. A list of costs (water, electricity, detergent, tank cleaning)
3. Months ( Jan, FebÂ…December)

the code will create/update a table where the user will input the all costs per month and site. table is located in tab “VARIABLE_COST”

1. List of sites located in tab “SITE_ASSUMPTIONS”: it is starts in cell P9. The user can insert new sites and/or delete sites
2. List of costs located in tab “costs_list” starting in A2 and the user can add more costs to the current list
3. Months located in tab “VARIABLE_COST” it is already input so nothing to do


I have the following code which creates/updates the sites and costs in column A and B in tab “VARIABLE_COST” .
it works well however is not dynamic if the user change the number of sites the costs rows wont move accordingly.

if a site is deleted in tab "site assumptions" the rows related to that site in "Variable cost" must be deleted.

Whether we add new sites or delete the table in "variable Cost" must be compact (no blank rows in between sites)

 Sub create_variable_costs_assumptions()

    Dim CostLst As Range
    Dim CostRws As Integer
    Dim usdrws As Long
    Dim i As Long
    Dim ValU As Range
    
Application.ScreenUpdating = False
    CostRws = Sheet21.Range("A2").CurrentRegion.Rows.Count
    Set CostLst = Sheet21.Range("A2:A" & CostRws)


    i = 2
    For Each ValU In Sheet8.Range("P9:P" & Sheet8.Range("P9").End(xlDown).Row)
        Sheet12.Range("A" & i).Resize(CostRws - 1) = ValU
        Sheet12.Range("B" & i).Resize(CostRws - 1) = CostLst.Value
        i = i + CostRws - 1
    Next ValU
    
Application.ScreenUpdating = False




End Sub

thanks in advance

Anthony

 

[Fluff]

Hia try this

Sub updateSht()

    Dim CostLst As Range
    Dim CostRws As Integer
    Dim Nxt As Long
    Dim SiteDict As Scripting.Dictionary
    Dim SiteRng As Range
    Dim SRng As Range
    Dim VCRng As Range
    Dim Rng As Range
    Dim Cnt As Long
    Dim Qty As Integer

Application.ScreenUpdating = False

    Set SiteDict = CreateObject("Scripting.Dictionary")
    Set SiteRng = Sheet8.Range("P9:P" & Sheet8.Range("P9").End(xlDown).Row)
    Set VCRng = Sheet12.Range("A2:A" & Sheet12.Range("A1").End(xlDown).Row)
    CostRws = Sheet21.Range("A2").CurrentRegion.Rows.Count - 1
    Set CostLst = Sheet21.Range("A2:A" & CostRws + 1)
    
    With SiteDict
        For Each SRng In SiteRng
            If Not .Exists(SRng.Text) Then .Add SRng.Text, Nothing
        Next SRng
    
        For Cnt = 0 To .Count - 1
            If WorksheetFunction.CountIf(VCRng, .Keys(Cnt)) = 0 Then
                Nxt = Sheet12.Range("A" & Rows.Count).End(xlUp).Offset(1).Row
                Sheet12.Range("A" & Nxt).Resize(CostRws) = .Keys(Cnt)
                Sheet12.Range("B" & Nxt).Resize(CostRws) = CostLst.Value
            End If
        Next Cnt
        
        For Each Rng In VCRng
            If Not .Exists(Rng.Text) Then
                Rng[COLOR=#0000ff].EntireRow.Interior.ColorIndex = 3[/COLOR]
            End If
        Next Rng
    End With

    With Sheet12
        Nxt = .Range("A" & Rows.Count).End(xlUp).Row
        Set VCRng = .Range("A2:A" & .Range("A1").End(xlDown).Row)
        For Cnt = Nxt To 2 Step -1
            Qty = WorksheetFunction.CountIf(VCRng, Range("A" & Cnt).Text)
            If Qty <> CostRws Then
                .Rows(Cnt + 1).Resize(CostRws - Qty).Insert
                .Range("A" & Cnt + 1).Resize(CostRws - Qty) = Range("A" & Cnt)
                .Range("B" & Cnt + 1).Resize(CostRws - Qty) = CostLst.Range(Qty + 1 & ":" & CostRws + 1).Value
                Cnt = Cnt - (Qty - 1)
            End If
        Next Cnt
    End With

Application.ScreenUpdating = True

End Sub

For testing purposes this will not delete any rows, just highlight them in red. If all ok change the line in blue.
You may also need to add a reference to Microsoft Scripting runtime.
To do this in the VB editor click Tools>References then scroll down to Microsoft Scripting runtime & select the check box

 

[Fluff]

Hia
Realised that the above code does not work properly.
Try this instead.
I have also added some extra code (in blue)to the bottom that will sort & format the data

Sub updateSht()

    Dim CostLst As Range
    Dim CostRws As Integer
    Dim Nxt As Long
    Dim SiteDict As Object
    Dim SiteLst As Variant
    Dim SiteRng As Range
    Dim SRng As Range
    Dim VCRng As Range
    Dim Rng As Range
    Dim Cnt As Long
    Dim Qty As Integer
    Dim NxtCol As Integer
    Dim UsdRws As Long
    Dim i As Long

Application.ScreenUpdating = False

    Set SiteDict = CreateObject("Scripting.Dictionary")
    Set SiteRng = Sheet8.Range("P9:P" & Sheet8.Range("P" & Rows.Count).End(xlUp).Row)
    UsdRws = Sheet12.Range("A" & Rows.Count).End(xlUp).Row
    Set VCRng = Sheet12.Range("A2:A" & UsdRws)
    CostRws = Sheet21.Range("A2").CurrentRegion.Rows.Count - 1
    Set CostLst = Sheet21.Range("A2:A" & CostRws + 1)
    
    With SiteDict
        For Each SRng In SiteRng
            If Not .Exists(SRng.Text) Then .Add SRng.Text, Nothing
        Next SRng
        SiteLst = .Keys
    End With

    With Sheet12
        For i = UsdRws To 2 Step -1
            If IsError(Application.Match(.Range("A" & i).Value, SiteLst, 0)) Then .Range("A" & i) = ""
        Next i
        On Error Resume Next
            .Range("A2:A" & UsdRws).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
        On Error GoTo 0
        
        For Cnt = 0 To SiteDict.Count - 1
            If WorksheetFunction.CountIf(VCRng, SiteLst(Cnt)) = 0 Then
                Nxt = .Range("A" & Rows.Count).End(xlUp).Offset(1).Row
                .Range("A" & Nxt).Resize(CostRws) = SiteLst(Cnt)
                .Range("B" & Nxt).Resize(CostRws) = CostLst.Value
            End If
        Next Cnt

        Nxt = .Range("A" & Rows.Count).End(xlUp).Row
        UsdRws = .Range("A" & Rows.Count).End(xlUp).Row
        Set VCRng = .Range("A2:A" & UsdRws)
        For Cnt = Nxt To 2 Step -1
            Qty = WorksheetFunction.CountIf(VCRng, .Range("A" & Cnt).Text)
            If Qty <> CostRws Then
                .Rows(Cnt + 1).Resize(CostRws - Qty).Insert
                .Range("A" & Cnt + 1).Resize(CostRws - Qty) = .Range("A" & Cnt)
                .Range("B" & Cnt + 1).Resize(CostRws - Qty) = CostLst.Range(Qty + 1 & ":" & CostRws + 1).Value
                Cnt = Cnt - (Qty - 1)
            End If
        Next Cnt
        
       [COLOR=#0000ff] NxtCol = .Cells(1, Columns.Count).End(xlToLeft).Offset(, 1).Column
        UsdRws = .Range("A" & Rows.Count).End(xlUp).Row
        .Cells(2, NxtCol).Resize(UsdRws - 1).Formula = "=int(right(A2,len(A2)-2))"
        .Cells.Sort Key1:=.Range("O2"), Order1:=xlAscending, Header:=xlYes, _
            OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
            DataOption1:=xlSortNormal
        .Columns(NxtCol).Delete

        For Cnt = UsdRws To 2 Step -1
            .Range("A" & Cnt).Offset(-CostRws + 1).Resize(CostRws, NxtCol - 1).Interior.ColorIndex = 19
            If Cnt - CostRws <> 1 Then
                .Range("A" & Cnt - CostRws).Offset(-CostRws + 1).Resize(CostRws, NxtCol - 1).Interior.ColorIndex = 36
            End If
            Cnt = Cnt - (CostRws * 2) + 1
        Next Cnt
        
        With .Range(.Cells(1, 1), .Cells(UsdRws, NxtCol - 1)).Borders
            .LineStyle = xlContinuous
            .Weight = xlHairline
            .ColorIndex = xlAutomatic
        End With
    End With
[/COLOR]


Application.ScreenUpdating = True

End Sub

 

[ANTONIO1981]

Sorry for the delay , thank you so much, you are a star!. i tested it works fantantisc

 

[Fluff]

Glad to help & thanks for the feedback