automatic update in other sheets: need some changes to the existing code

[aravindhan_31]

Hi,

I have already got an anwer for this long back from this site. The code was writted by Mr. Krishnakumar
the thread is here : http://www.mrexcel.com/forum/showthread.php?t=236699


i need some changes to be made in this code. The existing code creates and updates the details in the sheets automatically from the master data. I just need the sum of Column I in all the sheets after the last row of Column I.

selecting all the sheets and typing the formula in I column is not possible because, the last row in Column I is different in all the sheets.
In sheet 1, the last row of Column I is Row 15, in sheet 2 Row150 is the last row.
I guess something could be done in macros.

follwing is the existing code:

 Sub TestIt()
Dim sWS     As Worksheet
Dim Sellers As Range, Seller    As Range
Dim lRow    As Long, fRow       As Integer
Dim CopyRng As Range, ws        As Worksheet

Set sWS = Worksheets("Data")
lRow = sWS.Range("A" & Rows.Count).End(xlUp).Row
    Application.ScreenUpdating = False
    sWS.Columns(1).Insert
    sWS.Range("B1:B" & lRow).AdvancedFilter Action:=xlFilterCopy, _
        CopyToRange:=sWS.Range("A1"), Unique:=True
fRow = sWS.Range("A" & Rows.Count).End(xlUp).Row
Set Sellers = sWS.Range("A2:A" & fRow)
    For Each Seller In Sellers
        With sWS.Range("B1:B" & lRow)
            .AutoFilter Field:=1, Criteria1:=Seller
            Set CopyRng = .Offset(0, 0).Resize(.Rows.Count, Columns.Count - 1). _
                SpecialCells(xlCellTypeVisible)
            On Error Resume Next
            Set ws = Sheets(Seller.Value)
            On Error GoTo 0
            If Not ws Is Nothing Then
                CopyRng.Copy
                ws.Range("A1").PasteSpecial xlPasteValues
            Else
                Set ws = Sheets.Add
                ws.Name = Seller.Value
                CopyRng.Copy
                ws.Range("A1").PasteSpecial xlPasteValues
            End If
            .AutoFilter
        End With
        Set ws = Nothing
        Set CopyRng = Nothing
    Next Seller
    sWS.Columns(1).Delete
    Application.ScreenUpdating = True
End Sub

 

[Krishnakumar]

Hi,

Sub TestIt()
Dim sWS     As Worksheet, Heads As Range
Dim Sellers As Range, Seller    As Range
Dim lRow    As Long, fRow       As Integer
Dim CopyRng As Range, ws        As Worksheet

Set sWS = Worksheets("Data")
lRow = sWS.Range("A" & Rows.Count).End(xlUp).Row
    Application.ScreenUpdating = False
    sWS.Columns(1).Insert
    sWS.Range("B1:B" & lRow).AdvancedFilter Action:=xlFilterCopy, _
        CopyToRange:=sWS.Range("A1"), Unique:=True
    Set Heads = sWS.Range("b1:i1") 'col heads. adjust the range
fRow = sWS.Range("A" & Rows.Count).End(xlUp).Row
Set Sellers = sWS.Range("A2:A" & fRow)
    For Each Seller In Sellers
        With sWS.Range("B1:B" & lRow)
            .AutoFilter Field:=1, Criteria1:=Seller
            Set CopyRng = .Offset(0, 0).Resize(.Rows.Count, Columns.Count - 1). _
                SpecialCells(xlCellTypeVisible)
            On Error Resume Next
            Set ws = Sheets(Seller.Value)
            On Error GoTo 0
            If Not ws Is Nothing Then
                Heads.Copy
                ws.Range("a1").PasteSpecial (xlPasteFormats)
                CopyRng.Copy
                ws.Range("A1").PasteSpecial xlPasteValues
                ws.Cells(Rows.Count, 9).End(xlUp).Offset(1, 0).Formula = _
                "=SUM(R1C:R[-1]C)"
                ws.Cells(Rows.Count, 9).End(xlUp).Font.Bold = True
                
            Else
                Set ws = Sheets.Add
                ws.Name = Seller.Value
                Heads.Copy
                ws.Range("a1").PasteSpecial (xlPasteFormats)
                CopyRng.Copy
                ws.Range("A1").PasteSpecial xlPasteValues
                ws.Cells(Rows.Count, 9).End(xlUp).Offset(1, 0).Formula = _
                "=SUM(R1C:R[-1]C)"
                ws.Cells(Rows.Count, 9).End(xlUp).Font.Bold = True
            End If
            .AutoFilter
        End With
        Set ws = Nothing
        Set CopyRng = Nothing
    Next Seller
    sWS.Columns(1).Delete
    Application.ScreenUpdating = True
End Sub

 

[aravindhan_31]

Hi,

Thanks Kris, But first time I am getting an error on the code you have given.
When I run this, new sheets are apprearing but, I am getting only the first row in all the sheets with the format, no other data after that...

Arvind

 

[Krishnakumar]

Hi,

Not sure about this.

change

Set CopyRng = .Offset(0, 0).Resize(.Rows.Count, Columns.Count - 1). _
                SpecialCells(xlCellTypeVisible)

with

Set CopyRng = .Offset(0, 0).Resize(.Rows.Count, 9).SpecialCells(xlCellTypeVisible)