Need help on VB macro to copy from one master sheet into many different different sheets

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
 

Excel Facts

Links? Where??
If Excel says you have links but you can't find them, go to Formulas, Name Manager. Look for old links to dead workbooks & delete.

Forum statistics

Threads
1,223,238
Messages
6,170,939
Members
452,368
Latest member
jayp2104

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top