preseb
06-15-2011, 05:57 AM
I utilize the macro below to take a single sheet of data and breakout information based on a specific column. In this case column D.
I use the macro for many different worksheets and the information I want to breakout is not always in column D.
What I would like to do is change it so that the range of data is selected with an input box and the data to break apart is also by an input box.
So when I run it, the macro will ask me the range of the data, which I will enter. Then the next input box would ask what column I want to break out the data.
Sub test()
Application.ScreenUpdating = False
Dim i As Range, LR As Long, ws As Worksheet, wb As Workbook, C As Range
LR = Range("A" & Rows.Count).End(xlUp).Row
Sheets("sheet1").Range("d1:d" & LR).AdvancedFilter xlFilterCopy, copytorange:=Range("h1"), unique:=True
For Each C In Range("h2:h" & Range("h" & Rows.Count).End(xlUp).Row)
On Error GoTo 1
Worksheets.Add(after:=Worksheets(Worksheets.Count)).Name = C.Value
Next C
1
For Each C In Sheets("sheet1").Range("h2:h" & Sheets("sheet1").Range("h" & Rows.Count).End(xlUp).Row)
Sheets("sheet1").Range("a1:d1").AutoFilter field:=4, Criteria1:=C.Value
Sheets("sheet1").Range("a1:d" & Sheets("sheet1").Range("a" & Rows.Count).End(xlUp).Row).SpecialCells(xlCellTypeVisible).Copy
For Each ws In ThisWorkbook.Worksheets
If ws.Name = C.Value Then
ws.Range("a1").PasteSpecial xlPasteColumnWidths
ws.Range("a1").PasteSpecial xlValue
ws.Range("a1").PasteSpecial xlPasteFormats
End If
Next ws
Sheets("sheet1").Range("a1:d1").AutoFilter
Application.CutCopyMode = False
Next C
Sheets("sheet1").Columns("h").Delete
Sheets("sheet1").Select
Application.ScreenUpdating = True
End Sub
I use the macro for many different worksheets and the information I want to breakout is not always in column D.
What I would like to do is change it so that the range of data is selected with an input box and the data to break apart is also by an input box.
So when I run it, the macro will ask me the range of the data, which I will enter. Then the next input box would ask what column I want to break out the data.
Sub test()
Application.ScreenUpdating = False
Dim i As Range, LR As Long, ws As Worksheet, wb As Workbook, C As Range
LR = Range("A" & Rows.Count).End(xlUp).Row
Sheets("sheet1").Range("d1:d" & LR).AdvancedFilter xlFilterCopy, copytorange:=Range("h1"), unique:=True
For Each C In Range("h2:h" & Range("h" & Rows.Count).End(xlUp).Row)
On Error GoTo 1
Worksheets.Add(after:=Worksheets(Worksheets.Count)).Name = C.Value
Next C
1
For Each C In Sheets("sheet1").Range("h2:h" & Sheets("sheet1").Range("h" & Rows.Count).End(xlUp).Row)
Sheets("sheet1").Range("a1:d1").AutoFilter field:=4, Criteria1:=C.Value
Sheets("sheet1").Range("a1:d" & Sheets("sheet1").Range("a" & Rows.Count).End(xlUp).Row).SpecialCells(xlCellTypeVisible).Copy
For Each ws In ThisWorkbook.Worksheets
If ws.Name = C.Value Then
ws.Range("a1").PasteSpecial xlPasteColumnWidths
ws.Range("a1").PasteSpecial xlValue
ws.Range("a1").PasteSpecial xlPasteFormats
End If
Next ws
Sheets("sheet1").Range("a1:d1").AutoFilter
Application.CutCopyMode = False
Next C
Sheets("sheet1").Columns("h").Delete
Sheets("sheet1").Select
Application.ScreenUpdating = True
End Sub