Posts by gerop5

  • VBA Help

    Hello,


    I have a problem with the below code in vba


    I cannot manage to loop the sum for each new worksheet after splitting


    I am a beginner.


    Please help me.


    Thank you


  • add autosum function in each new sheet

    Hello Community,

    Hope you are well.

    Please tell in the below code how can in each new sheet calculate the autosum function in the columns of "S" , "T", "u","V","W" and X.

    I want to autosum in the new sheet in the row 12(with the autosum calculate (s7:s11) and in the R column and the row 12 in the new sheets insert the word"total"

    Below you will find the code

    Sub Splitdatabycol()

    Dim lr As Long

    Dim ws As Worksheet

    Dim vcol, i As Integer

    Dim icol As Long

    Dim myarr As Variant

    Dim title As String

    Dim titlerow As Integer

    Dim xTRg As Range

    Dim xVRg As Range

    Dim xWSTRg As Worksheet

    Dim xWS As Worksheet

    On Error Resume Next

    Set xTRg = Application.InputBox("Please select the header rows:", "", Type:=8)

    If TypeName(xTRg) = "Nothing" Then Exit Sub

    Set xVRg = Application.InputBox("Please select the column you want to split data based on:", "", Type:=8)

    If TypeName(xVRg) = "Nothing" Then Exit Sub

    vcol = xVRg.Column

    Set ws = xTRg.Worksheet

    lr = ws.Cells(ws.Rows.Count, vcol).End(xlUp).Row

    title = xTRg.AddressLocal

    titlerow = xTRg.Cells(1).Row

    icol = ws.Columns.Count

    ws.Cells(1, icol) = "Unique"

    Application.DisplayAlerts = False

    If Not Evaluate("=ISREF('xTRgWs_Sheet!A1')") Then

    Sheets.Add(after:=Worksheets(Worksheets.Count)).Name = "xTRgWs_Sheet"

    Else

    Sheets("xTRgWs_Sheet").Delete

    Sheets.Add(after:=Worksheets(Worksheets.Count)).Name = "xTRgWs_Sheet"

    End If

    Set xWSTRg = Sheets("xTRgWs_Sheet")

    xTRg.Copy

    xWSTRg.Paste Destination:=xWSTRg.Range("A1")

    ws.Activate

    For i = (titlerow + xTRg.Rows.Count) To lr

    On Error Resume Next

    If ws.Cells(i, vcol) <> "" And Application.WorksheetFunction.Match(ws.Cells(i, vcol), ws.Columns(icol), 0) = 0 Then

    ws.Cells(ws.Rows.Count, icol).End(xlUp).Offset(1) = ws.Cells(i, vcol)

    End If

    Next

    myarr = Application.WorksheetFunction.Transpose(ws.Columns(icol).SpecialCells(xlCellTypeConstants))

    ws.Columns(icol).Clear

    For i = 2 To UBound(myarr)

    ws.Range(title).AutoFilter field:=vcol, Criteria1:=myarr(i) & ""

    If Not Evaluate("=ISREF('" & myarr(i) & "'!A1)") Then

    Set xWS = Sheets.Add(after:=Worksheets(Worksheets.Count))

    xWS.Name = myarr(i) & ""

    Else

    xWS.Move after:=Worksheets(Worksheets.Count)

    End If

    xWSTRg.Range(title).Copy

    xWS.Paste Destination:=xWS.Range("A1")

    ws.Range("A" & (titlerow + xTRg.Rows.Count) & ":A" & lr).EntireRow.Copy xWS.Range("A" & (titlerow + xTRg.Rows.Count))

    Sheets(myarr(i) & "").Columns.AutoFit

    Next

    xWSTRg.Delete

    ws.AutoFilterMode = False

    ws.Activate

    Application.DisplayAlerts = True

    End Sub