Input multiple ID and QTY in Excel VBA userform

L

liaaa

New Member
Joined
Sep 29, 2023
Messages
20
Office Version
  1. 2010
Platform
  1. Windows
Hello,
I'm trying to input multiple ID in the textbox IDITEM and the result is each id will be transferred to multiple rows in the worksheet "database". I also want to input qty for each id. I have tried this code but it's not working. Any help or tips are really appreciated.

Sub Submit()
Application.ScreenUpdating = False
Dim App As New Excel.Application
Dim wBook As Excel.Workbook
Dim FileName As String
Dim iRow As Long
FileName = ThisWorkbook.Path & "\Database.xlsm"

Dim IDITEM As Variant
Dim QTY As Variant
Dim j As Long
Dim k As Long


'CheckFile exist Or Not
If Dir(FileName) = "" Then
MsgBox "Database is missing!", vbOKOnly + vbCritical, "Error"
Exit Sub
End If

' Check to makesure the txtIDITEM is splittable
If InStr(UserForm1.TxtIDITEM.Value, ",") > 0 Then
IDITEM = Split(UserForm1.TxtIDITEM.Value, ",")
Else
IDITEM = Array(UserForm1.TxtIDITEM.Value)
End If
For j = LBound(IDITEM) To UBound(IDITEM)

' Check to makesure the txtQTY is splittable
If InStr(UserForm1.TxtQTY.Value, ",") > 0 Then
QTY = Split(UserForm1.TxtQTY.Value, ",")
Else
QTY = Array(UserForm1.TxtQTY.Value)
End If
For k = LBound(QTY) To UBound(QTY)


Set wBook = App.Workbooks.Open(FileName)
With wBook.Sheets("Database")
iRow = .Range("A" & Application.Rows.Count).End(xlUp).Row + 1
.Range("A" & iRow).Value = iRow - 1
.Range("B" & iRow).Value = UserForm1.TxtNODOCUMENT.Value
.Range("C" & iRow).Value = UserForm1.TxtNUMBER.Value
.Range("D" & iRow).Value = [Text(Now()+1, "DD-MM-YYY")]
.Range("E" & iRow).Value = UserForm1.CmbNIP.Value
.Range("F" & iRow).Value = UserForm1.TxtPROJECTNAME.Value
.Range("G" & iRow).Value = UserForm1.TxtNOCONTRACT.Value
.Range("H" & iRow).Value = IDITEM(j)
.Range("I" & iRow).Value = UserForm1.TxtITEM.Value
.Range("J" & iRow).Value = QTY(k)
.Range("K" & iRow).Value = UserForm1.TxtSATUAN.Value
.Range("L" & iRow).Value = UserForm1.TxtDELIVERYDATE.Value
.Range("M" & iRow).Value = UserForm1.TxtSUPPLIER.Value
.Range("N" & iRow).Value = Application.UserName


End With
wBook.Close savechanges:=True
App.Quit
Set App = Nothing

Next j
Next k

End Sub


Here is the link for the file
 

Excel Facts

Lock one reference in a formula
Need 1 part of a formula to always point to the same range? use $ signs: $V$2:$Z$99 will always point to V2:Z99, even after copying
Sort by date Sort by votes
You are proceeding to wrong Next item between j and k at the end of the code. Your code formatting can be improved to avoid such instances. Please try:
Option Explicit

VBA Code: 
Sub Submit()
  Application.ScreenUpdating = False
  Dim App As New Excel.Application
  Dim wBook As Excel.Workbook
  Dim FileName As String
  Dim iRow As Long
  FileName = ThisWorkbook.Path & "\Database.xlsm"
 
  Dim IDITEM As Variant
  Dim QTY As Variant
  Dim j As Long
  Dim k As Long
 
  'CheckFile exist Or Not
  If Dir(FileName) = "" Then
    MsgBox "Database is missing!", vbOKOnly + vbCritical, "Error"
    Exit Sub
  End If
 
  ' Check to makesure the txtIDITEM is splittable
  If InStr(UserForm1.TxtIDITEM.Value, ",") > 0 Then
    IDITEM = Split(UserForm1.TxtIDITEM.Value, ",")
  Else
    IDITEM = Array(UserForm1.TxtIDITEM.Value)
  End If
 
  For j = LBound(IDITEM) To UBound(IDITEM)
 
    ' Check to makesure the txtQTY is splittable
    If InStr(UserForm1.TxtQTY.Value, ",") > 0 Then
      QTY = Split(UserForm1.TxtQTY.Value, ",")
    Else
      QTY = Array(UserForm1.TxtQTY.Value)
    End If
 
    For k = LBound(QTY) To UBound(QTY)
      Set wBook = App.Workbooks.Open(FileName)
      With wBook.Sheets("Database")
      iRow = .Range("A" & Application.Rows.Count).End(xlUp).Row + 1
      .Range("A" & iRow).Value = iRow - 1
      .Range("B" & iRow).Value = UserForm1.TxtNODOCUMENT.Value
      .Range("C" & iRow).Value = UserForm1.TxtNUMBER.Value
      .Range("D" & iRow).Value = [Text(Now()+1, "DD-MM-YYY")]
      .Range("E" & iRow).Value = UserForm1.CmbNIP.Value
      .Range("F" & iRow).Value = UserForm1.TxtPROJECTNAME.Value
      .Range("G" & iRow).Value = UserForm1.TxtNOCONTRACT.Value
      .Range("H" & iRow).Value = IDITEM(j)
      .Range("I" & iRow).Value = UserForm1.TxtITEM.Value
      .Range("J" & iRow).Value = QTY(k)
      .Range("K" & iRow).Value = UserForm1.TxtSATUAN.Value
      .Range("L" & iRow).Value = UserForm1.TxtDELIVERYDATE.Value
      .Range("M" & iRow).Value = UserForm1.TxtSUPPLIER.Value
      .Range("N" & iRow).Value = Application.UserName
      End With

      wBook.Close savechanges:=True
      App.Quit
      Set App = Nothing
    Next k
  Next j

End Sub
 
Upvote 0
Hi,
Thank you very much for your help. I have tried your code.

I have input data in userform like this.
1697204912160.png

And in the database sheets, the data appears like this, the output is repeated three times. Can you help me to fix this? Thank youu
1697205097421.png
 
Upvote 0
This should be OK:
VBA Code: 
Sub Submit()
  Application.ScreenUpdating = False
  Dim App As New Excel.Application
  Dim wBook As Excel.Workbook
  Dim FileName As String
  Dim iRow As Long
  FileName = ThisWorkbook.Path & "\Database.xlsm"
 
  Dim IDITEM As Variant
  Dim QTY As Variant
  Dim j As Long
 
  'CheckFile exist Or Not
  If Dir(FileName) = "" Then
    MsgBox "Database is missing!", vbOKOnly + vbCritical, "Error"
    Exit Sub
  End If
 
  ' Check to makesure the txtIDITEM is splittable
  If InStr(UserForm1.TxtIDITEM.Value, ",") > 0 Then
    IDITEM = Split(UserForm1.TxtIDITEM.Value, ",")
  Else
    IDITEM = Array(UserForm1.TxtIDITEM.Value)
  End If
 
  For j = LBound(IDITEM) To UBound(IDITEM)
 
    ' Check to makesure the txtQTY is splittable
    If InStr(UserForm1.TxtQTY.Value, ",") > 0 Then
      QTY = Split(UserForm1.TxtQTY.Value, ",")
    Else
      QTY = Array(UserForm1.TxtQTY.Value)
    End If
 
    Set wBook = App.Workbooks.Open(FileName)
    With wBook.Sheets("Database")
    iRow = .Range("A" & Application.Rows.Count).End(xlUp).Row + 1
    .Range("A" & iRow).Value = iRow - 1
    .Range("B" & iRow).Value = UserForm1.TxtNODOCUMENT.Value
    .Range("C" & iRow).Value = UserForm1.TxtNUMBER.Value
    .Range("D" & iRow).Value = [Text(Now()+1, "DD-MM-YYY")]
    .Range("E" & iRow).Value = UserForm1.CmbNIP.Value
    .Range("F" & iRow).Value = UserForm1.TxtPROJECTNAME.Value
    .Range("G" & iRow).Value = UserForm1.TxtNOCONTRACT.Value
    .Range("H" & iRow).Value = IDITEM(j)
    .Range("I" & iRow).Value = UserForm1.TxtITEM.Value
    .Range("J" & iRow).Value = QTY(j)
    .Range("K" & iRow).Value = UserForm1.TxtSATUAN.Value
    .Range("L" & iRow).Value = UserForm1.TxtDELIVERYDATE.Value
    .Range("M" & iRow).Value = UserForm1.TxtSUPPLIER.Value
    .Range("N" & iRow).Value = Application.UserName
    End With

    wBook.Close savechanges:=True
    App.Quit
    Set App = Nothing
  Next

End Sub
 
Upvote 0
Solution
You must log in or register to reply here.

Similar threads

P
  • Question Question
ListBox Click to textbox & delete row
Replies
0
Views
607
pure vito
P
A
  • Question Question
Macros for cleaning excel file
2
Replies
18
Views
829
jolivanes
jolivanes
K
  • Solved
Code to search job id from multiple sources and update main spreadsheet.
2
Replies
10
Views
642
mumps
mumps
C
  • Question Question
Import data based other workbook's data and filter
Replies
0
Views
424
CamBF
C
Q
  • Solved
Alternatives for the populating of a ComboBox
Replies
7
Views
571
quemuenchatocha
Q

Forum statistics

Threads
1,223,894
Messages
6,175,250
Members
452,623
Latest member
Techenthusiast

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