retrieve values, create worksheets in same workbook

[freezefiz]

hey everyone...

perhaps this question might be an easy task to many of you great ppl out there..

my codings are able to retrieve values BUT its saved as individual workbooks.

The ultimate outcome is that its saved as worksheets, in a newly created workbook in a particular folder.

Private Sub CommandButton2_Click()
    Dim Rng As Range
    Dim c As Range
    Dim List As New Collection
    Dim name As Variant
    Dim WbkNew As Workbook
    Dim wbkName As String
    Dim shName As String
    
Dim Sh As Worksheet
Set Sh = Worksheets("db")
Application.ScreenUpdating = False
   
Dim template As Worksheet
Set template = ActiveWorkbook.Sheets("template")
     
Dim ShProd As Worksheet
Set ShProd = ActiveWorkbook.Sheets("products")
Application.ScreenUpdating = False

With Sh
       
     With .Range("J2:J" & .Range("B" & .Rows.Count).End(xlUp).Row)
    .FormulaR1C1 = "=VLOOKUP(RC[-5],DriverAllocation!C[-9]:C[-8],2,FALSE)"
    .Copy
    .PasteSpecial Paste:=xlValues

End With

 'add individual driver's name to list(store)
        Set Rng = .Range("J2:J" & .Range("J" & .Rows.Count).End(xlUp).Row)
        On Error Resume Next
        For Each c In Rng
            List.Add c.Value, CStr(c.Value)
        Next c
        On Error GoTo 0
   'range to be copied to individual driver's worksheet
        Set Rng = .Range("A1:J" & .Range("A" & .Rows.Count).End(xlUp).Row)
      
  For Each name In List 'for each driver
           Set ShNew = Workbooks.Add
        
template.Range("A1").Copy
    
      With ShNew
               wbkName = name 'item=driver's name
                
template.Cells.Copy Destination:=ShNew.Sheets("Sheet1").Range("A1")
Worksheets("Sheet1").Cells(3, 11).Value = wbkName
 
Dim intRow As Integer
Dim rProd As Range, rCust As Range
intRow = 2
 
Do While Sh.Cells(intRow, 5).Value <> ""
 
If CStr(Sh.Cells(intRow, 10).Value) = Worksheets("Sheet1").Cells(3, 11).Value Then
 
Worksheets("Sheet1").Range("a3") = "Date"
Worksheets("Sheet1").Range("a4") = "Area"
Worksheets("Sheet1").Range("j3") = "Driver"
Worksheets("Sheet1").Range("j4") = "Vehicle"
Worksheets("Sheet1").Range("a5") = " "
Worksheets("Sheet1").Range("a6") = "S/NO"
Worksheets("Sheet1").Range("b5") = " "
Worksheets("Sheet1").Range("b6") = "CustID"
Worksheets("Sheet1").Range("c5") = " "
Worksheets("Sheet1").Range("c6") = "Customer"
Worksheets("Sheet1").Range("d5") = " "
Worksheets("Sheet1").Range("d6") = "Invoice"
Worksheets("Sheet1").Range("e5") = " "
Worksheets("Sheet1").Range("e6") = "Remarks"
   
    proid = Sh.Cells(intRow, 6).Value
    pro = Sh.Cells(intRow, 7).Value
    Set rProd = Worksheets("Sheet1").Cells(5, Columns.Count).End(xlToLeft)
    rProd.Offset(0, 1).Value = proid
    rProd.Offset(1, 1).Value = pro
    
custID = Sh.Cells(intRow, 4).Value
    cust = Sh.Cells(intRow, 5).Value
    Set rCust = Worksheets("Sheet1").Range("b" & Columns.Count).End(xlUp)
    rCust.Offset(1, 0).Resize(, 2) = Array(cust, custID)
    
qty = Sh.Cells(intRow, 8).Value
    Worksheets("Sheet1").Cells(rCust.Row + 1, rProd.Column + 1).Value = qty 'Cells(,start at which column?)
           End If
            
            intRow = intRow + 1
        Loop
    
    ShNew.SaveAs ThisWorkbook.Path & "\" & "LOGISTIC" & "\" & wbkName
    ShNew.Close True
     
            End With
        Next name
   
    
    End With
    
    Application.ScreenUpdating = True
 
End Sub

and.. instead naming the workbook.. i'd like to name the worksheets.

Help Help pls.

Thanks.

 

[Von Pookie]

I don't have time to look over your code that closely, but at first glance I can tell you to move 'Set ShNew = Workbooks.Add' out of the loop. In it's current place in the code, this will create a new workbook every time it loops.

You should also be using WbkNew as the variable there, not ShNew. You dimmed a WbkNew variable, not ShNew