Create Workbooks based on Unique Values from a Column

[aravindhan_3]

Hi,

I have a workbook with about 10000 rows of data for about 100 suppliers in Sheet1 and about 15000 rows of same Suppliers payment details in sheet2.

What I am doing now is:-
Filter every supplier names in Column A of sheet1, copy all the rows and paste in sheet1 of a new workook & Again copy the
Payment details of a same supplier from master file sheet2 and paste the same in sheet2 of this new workbook then save the files with the supplier name as file name in my documents folder

Can someone help me with the code, that filters each suppliers data from sheet1 & 2 and paste in new workbook sheet1 & 2.

Thanks for your help
Arvind.
Cross post:- http://www.mrexcel.com/forum/excel-q...es-column.html

http://www.excelforum.com/excel-prog...html?p=2962354

[mohanvijay]

Can you please post sample workbook with data

[aravindhan_3]

Hi MohanVijay,

Attached the sample file, the supplier names in Column C in both sheets.

in the sample file, there is data for 4 suppliers, so 4 workbooks should be created with 2 sheets with the same sheet name.

Thanks for your help.
Arvind

[mohanvijay]

Try this

[vba]

Sub Copy_To_Workbooks()
Dim WK_New As Workbook
Dim WS_Sup As Worksheet, WS_Pay As Worksheet
Dim L_Rw_S As Long, L_Rw_P As Long
Dim i As Long, T_Lng As Long
Dim S_Name As String
Set WS_Sup = ThisWorkbook.Sheets("Supplies")
Set WS_Pay = ThisWorkbook.Sheets("Payment")
L_Rw_P = WS_Pay.Cells(Rows.Count, 1).End(xlUp).Row
If WS_Pay.FilterMode = True Then WS_Pay.ShowAllData
Application.SheetsInNewWorkbook = 3
With WS_Sup

If .FilterMode = True Then .ShowAllData

L_Rw_S = .Cells(Rows.Count, 1).End(xlUp).Row
.Range("c1:c" & L_Rw_S).AdvancedFilter xlFilterCopy, Empty, .Range("AE1"), True

T_Lng = .Cells(Rows.Count, "ae").End(xlUp).Row

.Range("af1").Value = "Supplier Name"


For i = 2 To T_Lng

S_Name = .Cells(i, "ae").Value
.Range("af2").Value = S_Name
.Range("a1:ad" & L_Rw_S).AdvancedFilter xlFilterInPlace, .Range("af1:af2")
WS_Pay.Range("a1:t" & L_Rw_P).AdvancedFilter xlFilterInPlace, .Range("af1:af2")

Set WK_New = Workbooks.Add

WK_New.Sheets(1).Name = "Supplies"
WK_New.Sheets(2).Name = "Payment"

.Range("a1:ad" & L_Rw_S).SpecialCells(xlCellTypeVisible).Copy WK_New.Sheets(1).Range("a1")
WS_Pay.Range("a1:t" & L_Rw_P).SpecialCells(xlCellTypeVisible).Copy WK_New.Sheets(2).Range("a1")

WK_New.SaveAs "C:\Users\vijay\Desktop\vba-x\" & S_Name & ".xlsx" 'Change to your suit
WK_New.Close
Set WK_New = Nothing

Next i


End With

End Sub
[/vba]

[aravindhan_3]

Hi Vijay,

Thank you very much for your help, it worked, exactly satisfied my requirements.

Regards
Arvind

[aravindhan_3]

Hi Vijay,

The code works,

however I wanted to add a validation list in supplier sheet Cell AA2 till the end, i modified the code little bit, but getting error while validating

[vba]
Sub Create_HOD()
Application.ScreenUpdating = False
Dim WK_New As Workbook
Dim WS_Sup As Worksheet, WS_Pay As Worksheet
Dim L_Rw_S As Long, L_Rw_P As Long
Dim i As Long, T_Lng As Long
Dim S_Name As String
Set WS_Sup = ThisWorkbook.Sheets("(1) All lines ")
Set WS_Pay = ThisWorkbook.Sheets("(2) All lines extra detail")
L_Rw_P = WS_Pay.Cells(Rows.Count, 1).End(xlUp).Row
If WS_Pay.FilterMode = True Then WS_Pay.ShowAllData
Application.SheetsInNewWorkbook = 3
With WS_Sup

If .FilterMode = True Then .ShowAllData

L_Rw_S = .Cells(Rows.Count, 1).End(xlUp).Row
.Range("C1:C" & L_Rw_S).AdvancedFilter xlFilterCopy, Empty, .Range("AE1"), True

T_Lng = .Cells(Rows.Count, "ae").End(xlUp).Row

.Range("af1").Value = "HOD"

For i = 2 To T_Lng

S_Name = .Cells(i, "ae").Value
.Range("af2").Value = S_Name
.Range("a1:ad" & L_Rw_S).AdvancedFilter xlFilterInPlace, .Range("af1:af2")
WS_Pay.Range("a1:t" & L_Rw_P).AdvancedFilter xlFilterInPlace, .Range("af1:af2")

Set WK_New = Workbooks.Add

WK_New.Sheets(1).Name = "(1) All lines "
WK_New.Sheets(2).Name = "(2) All lines extra detail"
' Add items for data validation in sheet3.
WK_New.Sheets(3).Select
ActiveCell.FormulaR1C1 = "Already matched"
Range("A2").Select
ActiveCell.FormulaR1C1 = "Buyer to investigate"
Range("A3").Select
ActiveCell.FormulaR1C1 = "Change sent to Peters team-Amazon,Retail"
Range("A4").Select
ActiveCell.FormulaR1C1 = "FX Increase"
Range("A5").Select
ActiveCell.FormulaR1C1 = "Competitor price will be matched"
Range("A6").Select
ActiveCell.FormulaR1C1 = "Going on promotion"
Range("A7").Select
ActiveCell.FormulaR1C1 = "Incorrect competitor price "
Range("A8").Select
ActiveCell.FormulaR1C1 = "Incorrect conversion in basket"
Range("A9").Select
ActiveCell.FormulaR1C1 = "VAT increase"
Range("A10").Select
ActiveCell.FormulaR1C1 = _
"Price checkers not comparing to right competitor product - DS,SV"
Range("A11").Select
ActiveCell.FormulaR1C1 = "Price move"
Range("A12").Select
ActiveCell.FormulaR1C1 = "Product to be sourced"
Range("A13").Select
ActiveCell.FormulaR1C1 = "Promotion in competitor"
Range("A14").Select
ActiveCell.FormulaR1C1 = "Promotion in Big London"
Range("A15").Select
ActiveCell.FormulaR1C1 = "Sign off by price group"
Range("A16").Select
ActiveCell.FormulaR1C1 = "Wrong Big Price"
WK_New.Sheets(3).Visible = False

.Range("a1:ad" & L_Rw_S).SpecialCells(xlCellTypeVisible).Copy WK_New.Sheets(1).Range("a1")
WS_Pay.Range("a1:t" & L_Rw_P).SpecialCells(xlCellTypeVisible).Copy
WK_New.Sheets(2).Range("a1")
' in sheet 3 Cell AA2 Add validation and fill till the end
WK_New.Sheet(3).Range("AA2").Select
With Selection.Validation
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
xlBetween, Formula1:="=Comments"
.IgnoreBlank = True
.InCellDropdown = True
.InputTitle = ""
.ErrorTitle = ""
.InputMessage = ""
.ErrorMessage = ""
.ShowInput = True
.ShowError = True
LR = Range("A" & Rows.Count).End(xlUp).Row
Range("AA2:AA" & LR).Select
Selection.FillDown
Range("A1").Select
End With

WK_New.SaveAs "D:\Macros\Macros arvind\Macros arvind\OOP\baskets\Splits\HOD\" & S_Name & ".xls" 'Change to your suit
WK_New.Close
Set WK_New = Nothing
Next i
ActiveSheet.ShowAllData
Columns("AE:AF").Select
Selection.Clear
Range("A1").Select
End With
End Sub
[/vba]

Can you help me with this?
Arvind

[mohanvijay]

Try this

[vba]
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
xlBetween, Formula1:="=$A$2:$A$16"
[/vba]

You may use following code to set list

[vba]

WK_New.Sheets(3).Range("a1:o1") = Array("List1", "list2", "List3", "List4") 'Fill all
WK_New.Sheets(3).Range("a1:o1").Copy
WK_New.Sheets(3).Range("a2").PasteSpecial xlPasteAll, , , True
WK_New.Sheets(3).Range("a1:o1").Clear
[/vba]