retrieve values, create worksheets in same workbook


Board Regular
May 21, 2008
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.

Rich (BB code):
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)"
    .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
      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
    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.


Excel Facts

Prevent GETPIVOTDATA. Select inside a PivotTable. In the Analyze tab of the ribbon, open the dropown next to Options and turn it off

Von Pookie

MrExcel MVP
Feb 17, 2002
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 ;)
Upvote 0

Forum statistics

Latest member

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
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 "".
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