Userform Data Save in another workbook in the name of Location

C

champ007

New Member
Joined
Feb 27, 2013
Messages
8
hey guys,
i m a beginner in vba. I m having problem in upgrading my excel vba file.i made a stock data entry file in which i want that my file should create another workbook for each location while adding new location name and ignore if it has already created and add data to particular location say USA data to Usa.xlsx Canada data to canada.xlsx when i choose in location combo box. in same directory.
Code: 
Option Explicit


Private Sub OnlyNumbers()


    If TypeName(Me.ActiveControl) = "TextBox" Then


        With Me.ActiveControl


            If Not IsNumeric(.Value) And .Value <> vbNullString Then


                MsgBox "Sorry, only numbers allowed"


                .Value = vbNullString


            End If


        End With


    End If
End Sub


Private Sub cboType_AfterUpdate()
On Error Resume Next
Dim ws As Worksheet
Dim cPart As Range
Set ws = Worksheets("LookupLists")


Me.cboPart.Value = ""
Me.cboPart.RowSource = ""


With ws
   .Range("CritPartCat").Cells(2, 1).Value _
      = Me.cboType.Value
   .Columns("A:B").AdvancedFilter _
      Action:=xlFilterCopy, _
      CriteriaRange:=.Range("CritPartCat"), _
      CopyToRange:=.Range("ExtPartDesc"), _
      Unique:=False
End With


'redefine the static named range
ThisWorkbook.Names.Add Name:="PartSelList", _
  RefersTo:="=" & ws.Name & "!" & _
  ws.Range("PartSelCatList").Address


Me.cboPart.RowSource = "PartSelCatList"


End Sub








Private Sub cmdAdd_BeforeDragOver(ByVal Cancel As MSForms.ReturnBoolean, ByVal Data As MSForms.DataObject, ByVal X As Single, ByVal Y As Single, ByVal DragState As MSForms.fmDragState, ByVal Effect As MSForms.ReturnEffect, ByVal Shift As Integer)


End Sub
Private Sub cmdAdd1_Click()
Dim lPart As Long
Dim lRow As Long
Dim qPart As Long
Dim ws As Worksheet
Dim wsL As Worksheet
Dim rngListP As Range
Dim cPart As Range
Dim strinv As String
Dim strtype As String
Dim strPart As String
Dim strQty As String
Dim strPri As String
Dim strLoc As String
Dim lCount As Long
Set ws = Worksheets("PartsData")
Set wsL = Worksheets("LookupLists")
Set rngListP = wsL.Range("PartIDList")


strinv = Trim(Me.txtinv.Value)




If Trim(Me.txtinv.Value) = "" Then
  Me.txtinv.SetFocus
  MsgBox "Please enter Invoice No "
  Exit Sub
Else
  lCount = Application.WorksheetFunction.CountIf(rngListP, strinv)
  
End If


strPart = Trim(Me.cboPart.Value)


'find  first empty row in database
lRow = ws.Cells.Find(What:="*", SearchOrder:=xlRows, _
    SearchDirection:=xlPrevious, LookIn:=xlValues).Row + 1
    
qPart = Me.cboPart.ListIndex


'check for a part number
If Trim(Me.cboPart.Value) = "" Then
  Me.cboPart.SetFocus
  MsgBox "Please enter a Stock Description"
  Exit Sub
Else
  lCount = Application.WorksheetFunction.CountIf(rngListP, strPart)


End If


strtype = Trim(Me.cboType.Value)




If Trim(Me.cboType.Value) = "" Then
  Me.cboType.SetFocus
  MsgBox "Please enter Descritpion Type "
  Exit Sub
Else
  lCount = Application.WorksheetFunction.CountIf(rngListP, strtype)
  
End If


strQty = Trim(Me.txtQty.Value)




If Trim(Me.txtQty.Value) = "" Then
  Me.txtQty.SetFocus
  MsgBox "Please enter an Qnty"
  Exit Sub
Else
  lCount = Application.WorksheetFunction.CountIf(rngListP, strQty)
  
End If


strPri = Trim(Me.txtpri.Value)




If Trim(Me.txtpri.Value) = "" Then
  Me.txtpri.SetFocus
  MsgBox "Please enter Price"
  Exit Sub
Else
  lCount = Application.WorksheetFunction.CountIf(rngListP, strPri)


End If


strLoc = Trim(Me.cboLocation.Value)




If Trim(Me.cboLocation.Value) = "" Then
  Me.cboLocation.SetFocus
  MsgBox "Please enter Location"
  Exit Sub
Else
  lCount = Application.WorksheetFunction.CountIf(rngListP, strLoc)


End If


lPart = lstbox.ListCount
With Me.lstbox
    Me.lstbox.ColumnCount = 11
    Me.lstbox.ColumnWidths = "60;66;78;138;54;72;72;72;54;78"
    .AddItem
    .List(lPart, 0) = Me.txtinv.Value
    .List(lPart, 1) = Me.txtDate.Value
    .List(lPart, 2) = Me.cboType.Value
    .List(lPart, 3) = Me.cboPart.Value
    .List(lPart, 4) = Me.txtQty.Value
    .List(lPart, 5) = Me.txtpri.Value
    .List(lPart, 6) = Me.txtamt.Value
    .List(lPart, 7) = Me.cboLocation.Value
    .List(lPart, 8) = Me.cboven.Value
    .List(lPart, 9) = Me.cborem.Value
    
Me.cboType.Value = ""
Me.cboPart.Value = ""
Me.txtQty.Value = ""
Me.txtpri.Value = ""
Me.txtamt.Value = ""
Me.cborem.Value = ""
Me.Amount.Value = ""
End With


End Sub




Private Sub cmdAdd_Error(ByVal Number As Integer, ByVal Description As MSForms.ReturnString, ByVal SCode As Long, ByVal Source As String, ByVal HelpFile As String, ByVal HelpContext As Long, ByVal CancelDisplay As MSForms.ReturnBoolean)


End Sub


Private Sub cmdAdd_Exit(ByVal Cancel As MSForms.ReturnBoolean)


End Sub


[B]Private Sub cmdAdd_Click()
Dim i As Long, J As Long
'Change Workbook
Dim nwb As Workbook
Set nwb = Workbooks.Open("D:\New Folder\b.xlsx")
Dim ws As Worksheet
Set ws = Worksheets("Data")


nwb.Activate


With lstbox
    'The selection in ToListBox2 is pasted to the spreadsheet "COMPLETED" in columns M and O
    i = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row + 1
    
    
    With lstbox
            For J = 0 To .ListCount - 1
            ws.Cells(i, 1) = .List(J, 0)
            ws.Cells(i, 2) = .List(J, 1)
            ws.Cells(i, 3) = .List(J, 2)
            ws.Cells(i, 4) = .List(J, 3)
            ws.Cells(i, 5) = .List(J, 4)
            ws.Cells(i, 6) = .List(J, 5)
            ws.Cells(i, 7) = .List(J, 6)
            ws.Cells(i, 8) = .List(J, 7)
            ws.Cells(i, 9) = .List(J, 8)
            ws.Cells(i, 10) = .List(J, 9)
            i = i + 1
        Next J
        .Clear
    End With
    End With
End Sub
[/B]



Private Sub cmdClose_Click()
  Unload Me
End Sub




Private Sub cmdEdit_Click()
 If lstbox.ListIndex >= 0 Then
        lstbox.RemoveItem lstbox.ListIndex
    End If
End Sub


Private Sub CommandButton1_Click()
Dim i As Long
If lstbox.ListCount <> 0 Then
For i = 0 To lstbox.ListCount - 1
If Amount.Value = "" Then
Amount.Value = lstbox.List(i, 6)
Else
Amount.Value = WorksheetFunction.Sum(Amount.Value, lstbox.List(i, 6))
Amount.Value = Format(Amount.Value, "##,##0.00")
End If
Next
End If
End Sub


Private Sub Label1_BeforeDropOrPaste(ByVal Cancel As MSForms.ReturnBoolean, ByVal Action As MSForms.fmAction, ByVal Data As MSForms.DataObject, ByVal X As Single, ByVal Y As Single, ByVal Effect As MSForms.ReturnEffect, ByVal Shift As Integer)


End Sub






Private Sub txtamt_Change()
    OnlyNumbers
End Sub


Private Sub txtDate_Enter()
Dim myDate As Date


Set clsCal = New ClsCalendar


FormPicker.Show


myDate = clsCal.SelectedDate


If myDate > 0 Then  'Check to see if it was cancelled
    txtDate.Value = clsCal.SelectedDate
End If
End Sub




Private Sub txtpri_Change()
    OnlyNumbers
    Dim total As Double
    total = Val(txtQty.Value) * Val(txtpri.Value)
    txtamt.Value = total
    txtamt.Value = Format(txtamt.Value, "##,##,##,##,##,##0.00")
End Sub
Private Sub txtQty_Change()
    OnlyNumbers
    Dim total As Double
    total = Val(txtQty.Value) * Val(txtpri.Value)
    txtamt.Value = total
    txtamt.Value = Format(txtamt.Value, "##,##,##,##,##,##0.00")
End Sub


Private Sub UserForm_Initialize()
Dim cPart As Range
Dim cType As Range
Dim cLoc As Range
Dim cven As Range
Dim crem As Range
Dim total As Double
Dim ws As Worksheet
Set ws = Worksheets("LookupLists")
Dim myDate As Date
Set clsCal = New ClsCalendar


UpdateComboLists
Me.txtinv.Value = ""
Me.txtDate.Value = clsCal.SelectedDate
Me.txtQty.Value = ""
Me.txtpri.Value = ""
Me.txtamt.Value = ""
Me.Amount.Value = ""
Me.cboPart.SetFocus


End Sub


Private Sub UpdateComboLists()
Dim cPart As Range
Dim cType As Range
Dim cLoc As Range
Dim cven As Range
Dim crem As Range
Dim ws As Worksheet
Set ws = Worksheets("LookupLists")


With ws
   .Range("CritPartCat").Cells(2, 1).ClearContents
   .Range("PartSelList").ClearContents
End With


For Each cType In ws.Range("PartCatList")
  With Me.cboType
    .AddItem cType.Value
  End With
Next cType


Me.cboLocation.Clear
For Each cLoc In ws.Range("LocationList")
  With Me.cboLocation
    .AddItem cLoc.Value
  End With
Next cLoc


Me.cboven.Clear
For Each cven In ws.Range("VendorList")
  With Me.cboven
    .AddItem cven.Value
  End With
Next cven


Me.cborem.Clear
For Each crem In ws.Range("RemarksList")
  With Me.cborem
    .AddItem crem.Value
  End With
Next crem


Me.cboPart.RowSource = ""


End Sub
 
Last edited:

Excel Facts

How to calculate loan payments in Excel?
Use the PMT function: =PMT(5%/12,60,-25000) is for a $25,000 loan, 5% annual interest, 60 month loan.
Sort by date Sort by votes
You must log in or register to reply here.

Similar threads

S
  • Solved
Display data of Specific Sheets on Listbox Userform
2
Replies
11
Views
872
Akuini
Akuini
L
  • Solved
Autofill Userform TextBox with data on sheets
Replies
3
Views
257
dmt32
D
S
  • Solved
Working with multiple Target Ranges in Worksheet Code
Replies
3
Views
378
sspatriots
S
S
  • Question
Worksheet Change Event
Replies
2
Views
383
sspatriots
S
A
  • Solved
add another condition to filter data based on month in listbox on userform
Replies
3
Views
426
abdelfattah
A

Forum statistics

Threads
1,215,089
Messages
6,123,058
Members
449,091
Latest member
ikke

Share this page

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