Posts by gerop5


    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

    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"



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

    End If

    Set xWSTRg = Sheets("xTRgWs_Sheet")


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


    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


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


    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) & ""


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

    End If


    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



    ws.AutoFilterMode = False


    Application.DisplayAlerts = True

    End Sub