VBA Help

Sub ChrisVba()

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



For Each ws In ActiveWorkbook.Worksheets



LastRow = Cells(Rows.Count, "L").End(xlUp).Row

ws.Range("L" & LastRow + 1 & ":Q" & LastRow + 1).Formula = "=SUM(L7:L" & LastRow & ")"

LastRow1 = Cells(Rows.Count, "K").End(xlUp).Row

ws.Range("K" & LastRow1 + 1) = "Total"



Next ws



End Sub