Input multiple ID and QTY in Excel VBA userform

[liaaa]

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

Loading Google Sheets

Loading Google Sheets

 

[Legacy 143009]

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

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

 

[liaaa]

Hi,
Thank you very much for your help. I have tried your code.

I have input data in userform like this.

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

 

[Legacy 143009]

Could you please share an example for how data should look like?

 

[liaaa]

Could you please share an example for how data should look like?

This is for the example. each ID and QTY only appear once.

 

[Legacy 143009]

This should be OK:

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

 

[liaaa]

that's works perfectly, thank you so much.

 

[Legacy 143009]

I am glad it did work Thanks for the follow up