zeeshan7771
New Member
- Joined
- Nov 2, 2015
- Messages
- 1
Hello guys ! I am a newbie here so ignore if I make a mistake.
I have a macro that makes different files from one master file based on first column selection, copy all rows of that selection & saves into new workbook with the name of selection (Currently it saving from A6 till last row). It is working perfectly! What now I need that I have some rows above the selection criteria (A1:H5) and blow criteria (A19:H22). also save into each new work book.
I don't know VB that why I not able doing this thing. If you don't understand please run macro for one time with This data.
Looking forward for your Ideas. macro & data is following.
[TABLE="class: grid, width: 500"]
<tbody>[TR]
[TD]voFix Capsl[/TD]
[TD]45[/TD]
[TD]55[/TD]
[TD]78[/TD]
[TD]68[/TD]
[/TR]
[TR]
[TD]Fahad[/TD]
[TD]85[/TD]
[TD]84[/TD]
[TD]23[/TD]
[TD]98[/TD]
[/TR]
[TR]
[TD]voFix Capsl[/TD]
[TD]85[/TD]
[TD]88[/TD]
[TD]45[/TD]
[TD]52[/TD]
[/TR]
[TR]
[TD]Fahad[/TD]
[TD]3.0[/TD]
[TD]02[/TD]
[TD]54[/TD]
[TD]69[/TD]
[/TR]
[TR]
[TD]voFix Capsl[/TD]
[TD]52[/TD]
[TD]23[/TD]
[TD]00[/TD]
[TD]564[/TD]
[/TR]
[TR]
[TD]Fahad[/TD]
[TD]12[/TD]
[TD]12[/TD]
[TD]12[/TD]
[TD]21[/TD]
[/TR]
[TR]
[TD]Ioge M30[/TD]
[TD]12[/TD]
[TD]75[/TD]
[TD]23[/TD]
[TD]1[/TD]
[/TR]
[TR]
[TD]Ioge M30[/TD]
[TD]036[/TD]
[TD]56[/TD]
[TD]89[/TD]
[TD]27[/TD]
[/TR]
[TR]
[TD]Ioge M30[/TD]
[TD]7[/TD]
[TD]54[/TD]
[TD]6[/TD]
[TD]45[/TD]
[/TR]
</tbody>[/TABLE]
Sub Extract_All_Data_To_New_Workbook()
'this macro assumes that your first row of data is a header row.
'will copy all filtered rows from one worksheet, to another blank workbook
'each unique filtered value will be copied to it's own workbook
'Variables used by the macro
Dim wbDest As Workbook
Dim rngFilter As Range, rngUniques As Range
Dim cell As Range
' Set the filter range (from A1 to the last used cell in column A)
'(Note: you can change this to meet your requirements)
Set rngFilter = Range("A6", Range("A" & Rows.Count).End(xlUp))
Application.ScreenUpdating = False
With rngFilter
' Filter column A to show only one of each item (uniques) in column A
.AdvancedFilter Action:=xlFilterInPlace, Unique:=True
' Set a variable to the Unique values
Set rngUniques = Range("A6", Range("A" & Rows.Count).End(xlUp)).SpecialCells(xlCellTypeVisible)
' Clear the filter
ActiveSheet.ShowAllData
End With
' Filter, Copy, and Paste each unique to its own new workbook
For Each cell In rngUniques
' Create a new workbook for each unique value
Set wbDest = Workbooks.Add(xlWBATWorksheet)
'NOTE - this filter is on column A (field:=1), to change
'to a different column you need to change the field number
rngFilter.AutoFilter Field:=1, Criteria1:=cell.Value
' Copy and paste the filtered data to its new workbook
'Range("A1:h5").Copy
'rngFilter.EntireRow.Copy
rngFilter.EntireRow.Copy
' With wbDest.Sheets(1).Range("A1")
With wbDest.Sheets(1).Range("A6")
.PasteSpecial xlPasteColumnWidths 'Paste column widths
.PasteSpecial xlPasteValuesAndNumberFormats 'Paste values
.PasteSpecial Paste:=xlPasteFormats 'Paste formats ######
End With
Application.CutCopyMode = True
' Name the destination sheet
wbDest.Sheets(1).Name = cell.Value
'Save the destination workbook and close
wbDest.SaveAs ThisWorkbook.Path & Application.PathSeparator & _
cell.Value
' wbDest.Close False 'Close the new workbook
Next cell
rngFilter.Parent.AutoFilterMode = False
Application.ScreenUpdating = True
End Sub
I have a macro that makes different files from one master file based on first column selection, copy all rows of that selection & saves into new workbook with the name of selection (Currently it saving from A6 till last row). It is working perfectly! What now I need that I have some rows above the selection criteria (A1:H5) and blow criteria (A19:H22). also save into each new work book.
I don't know VB that why I not able doing this thing. If you don't understand please run macro for one time with This data.
Looking forward for your Ideas. macro & data is following.
[TABLE="class: grid, width: 500"]
<tbody>[TR]
[TD]voFix Capsl[/TD]
[TD]45[/TD]
[TD]55[/TD]
[TD]78[/TD]
[TD]68[/TD]
[/TR]
[TR]
[TD]Fahad[/TD]
[TD]85[/TD]
[TD]84[/TD]
[TD]23[/TD]
[TD]98[/TD]
[/TR]
[TR]
[TD]voFix Capsl[/TD]
[TD]85[/TD]
[TD]88[/TD]
[TD]45[/TD]
[TD]52[/TD]
[/TR]
[TR]
[TD]Fahad[/TD]
[TD]3.0[/TD]
[TD]02[/TD]
[TD]54[/TD]
[TD]69[/TD]
[/TR]
[TR]
[TD]voFix Capsl[/TD]
[TD]52[/TD]
[TD]23[/TD]
[TD]00[/TD]
[TD]564[/TD]
[/TR]
[TR]
[TD]Fahad[/TD]
[TD]12[/TD]
[TD]12[/TD]
[TD]12[/TD]
[TD]21[/TD]
[/TR]
[TR]
[TD]Ioge M30[/TD]
[TD]12[/TD]
[TD]75[/TD]
[TD]23[/TD]
[TD]1[/TD]
[/TR]
[TR]
[TD]Ioge M30[/TD]
[TD]036[/TD]
[TD]56[/TD]
[TD]89[/TD]
[TD]27[/TD]
[/TR]
[TR]
[TD]Ioge M30[/TD]
[TD]7[/TD]
[TD]54[/TD]
[TD]6[/TD]
[TD]45[/TD]
[/TR]
</tbody>[/TABLE]
Sub Extract_All_Data_To_New_Workbook()
'this macro assumes that your first row of data is a header row.
'will copy all filtered rows from one worksheet, to another blank workbook
'each unique filtered value will be copied to it's own workbook
'Variables used by the macro
Dim wbDest As Workbook
Dim rngFilter As Range, rngUniques As Range
Dim cell As Range
' Set the filter range (from A1 to the last used cell in column A)
'(Note: you can change this to meet your requirements)
Set rngFilter = Range("A6", Range("A" & Rows.Count).End(xlUp))
Application.ScreenUpdating = False
With rngFilter
' Filter column A to show only one of each item (uniques) in column A
.AdvancedFilter Action:=xlFilterInPlace, Unique:=True
' Set a variable to the Unique values
Set rngUniques = Range("A6", Range("A" & Rows.Count).End(xlUp)).SpecialCells(xlCellTypeVisible)
' Clear the filter
ActiveSheet.ShowAllData
End With
' Filter, Copy, and Paste each unique to its own new workbook
For Each cell In rngUniques
' Create a new workbook for each unique value
Set wbDest = Workbooks.Add(xlWBATWorksheet)
'NOTE - this filter is on column A (field:=1), to change
'to a different column you need to change the field number
rngFilter.AutoFilter Field:=1, Criteria1:=cell.Value
' Copy and paste the filtered data to its new workbook
'Range("A1:h5").Copy
'rngFilter.EntireRow.Copy
rngFilter.EntireRow.Copy
' With wbDest.Sheets(1).Range("A1")
With wbDest.Sheets(1).Range("A6")
.PasteSpecial xlPasteColumnWidths 'Paste column widths
.PasteSpecial xlPasteValuesAndNumberFormats 'Paste values
.PasteSpecial Paste:=xlPasteFormats 'Paste formats ######
End With
Application.CutCopyMode = True
' Name the destination sheet
wbDest.Sheets(1).Name = cell.Value
'Save the destination workbook and close
wbDest.SaveAs ThisWorkbook.Path & Application.PathSeparator & _
cell.Value
' wbDest.Close False 'Close the new workbook
Next cell
rngFilter.Parent.AutoFilterMode = False
Application.ScreenUpdating = True
End Sub