MohamedAmin
New Member
- Joined
- May 17, 2023
- Messages
- 21
- Office Version
- 2021
- Platform
- Windows
VBA Code:
ThisWorkbook.Activate
'=============================================
Dim X As Long
Dim xx As Long
Dim fwr As Integer
Dim fwo As Integer
mer = " Data Error : "
mtk = " Data Duplicate Error : "
If Me.CbInvStore.MatchFound = False Then: MsgBox mer & vbCrLf & vbCrLf & " Please select the type of invoice ", vbCritical + vbMsgBoxLeft, "Inventory Program ": Exit Sub
If Me.CbCustomerName.MatchFound = False Then: MsgBox mer & vbCrLf & vbCrLf & " Please select the name of client", vbCritical + vbMsgBoxLeft, "Inventory Program ": Exit Sub
'If Me.TbInvNo = "" Then: MsgBox mer & vbCrLf & vbCrLf & " Please enter the invoice number ", vbCritical + vbMsgBoxLeft, "Inventory Program ": Exit Sub
If Me.TbDate = "" Then: MsgBox mer & vbCrLf & vbCrLf & " Please enter the Invoice date ", vbCritical + vbMsgBoxLeft, "Inventory Program ": Exit Sub
If Me.ListBox1.ListCount <= 1 Then: MsgBox mer & vbCrLf & vbCrLf & " You have not added item to be saved ", vbCritical + vbMsgBoxLeft, "Inventory Program ": Exit Sub
'====check date entry '==
dtval = Val(Format(Me.TbDate, "0"))
mindt = 40909
maxdt = Val(Format(Date + 1, "0"))
If dtval < mindt Then: MsgBox mer & vbCrLf & vbCrLf & "Sorry .. Program does not accept date before the year 2012 ", vbCritical + vbMsgBoxLeft, "Inventory Program ": Exit Sub
If dtval > maxdt Then: MsgBox mer & vbCrLf & vbCrLf & "Sorry .. Program does not accept a future date ", vbCritical + vbMsgBoxLeft, "Inventory Program ": Exit Sub
'=========================
fwr = Application.WorksheetFunction.CountIfs(Rep.Range("C7:C80000"), Me.CbInvStore.Value, Rep.Range("F7:F80000"), Me.TbInvNo.Value) 'I need to change it to lastrow
fwrc = Application.WorksheetFunction.CountIfs(Repc.Range("B9:B30000"), Me.CbInvStore.Value, Repc.Range("D9:D30000"), Me.TbInvNo.Value) 'I need to change it to lastrow
fwo = Me.ListBox1.ListCount - 1 ' no of items
'==========================================================
If fwr < 1 Then: MsgBox mer & vbCrLf & vbCrLf & "Please enter the invoice number ", vbCritical + vbMsgBoxLeft, "Inventory Program ": Exit Sub
If fwrs < 1 Then: MsgBox mer & vbCrLf & vbCrLf & "Please enter the invoice number ", vbCritical + vbMsgBoxLeft, "Inventory Program ": Exit Sub
If fwrc < 1 Then: MsgBox mer & vbCrLf & vbCrLf & " Invoice number not found in the statement of the client's account", vbCritical + vbMsgBoxLeft, "Inventory Program ": Exit Sub
If fwrc > 1 Then: MsgBox mtk & vbCrLf & vbCrLf & " Duplicate invoice number " & fwrc & " Once ", vbCritical + vbMsgBoxLeft, "Inventory Program ": Exit Sub
If fwo < 1 Then: MsgBox mer & vbCrLf & vbCrLf & " There are no items to be adjusted ", vbCritical + vbMsgBoxLeft, "Inventory Program ": Exit Sub
confir = MsgBox("Would you like to save the change... ?", vbOKCancel, "Inventory Program ")
If confir = vbCancel Then: Exit Sub
Application.ScreenUpdating = False
On Error GoTo 1
With Rep
.Select
.Unprotect ("0000")
AutoFilterMode = False
.Range("$C$6:$Z$6").AutoFilter field:=2, Criteria1:=Me.CbInvStore.Value
.Range("$C$6:$Z$6").AutoFilter field:=5, Criteria1:=Me.TbInvNo.Value
lastrow = .Range("F80000").End(xlUp).Row + 1 'I need to change it to lastrow
.Range("$C$6:$Z$6").AutoFilter
If fwo = fwr Then
X = lastrow - fwr
xx = lastrow - 1
ElseIf fwo > fwr Then
d = fwo - fwr
X = lastrow - fwr
xx = lastrow + d - 1
.Range(Cells(lastrow, "c"), Cells(xx, "c")).Select
Selection.EntireRow.Insert , CopyOrigin:=xlFormatFromLeftOrAbove
ElseIf fwo < fwr Then
X = lastrow - fwr
xx = X + fwo - 1
Y = xx + 1
z = lastrow - 1
.Range(Cells(Y, "c"), Cells(z, "c")).Select
Selection.EntireRow.Delete
Else
MsgBox "There is somthing wrong. will be exit ", vbCritical, "Inventory Program "
End If
Me.TbDate.Text = Format(Me.TbDate.Text, "dd/mm/yyyy")
.Range(Rep.Cells(X, "B"), Rep.Cells(xx, "B")) = Me.comDepartment.Value 'Department
.Range(Rep.Cells(X, "C"), Rep.Cells(xx, "C")) = Me.CbInvStore.Value 'inv_store
.Range(Rep.Cells(X, "D"), Rep.Cells(xx, "D")) = Me.CbPayment.Value 'pay_method
.Range(Rep.Cells(X, "E"), Rep.Cells(xx, "E")) = Me.Lbl_typ.Caption 'inv_type
.Range(Rep.Cells(X, "F"), Rep.Cells(xx, "F")) = Format(Me.TbInvNo.Value, "00000") 'inv no
.Range(Rep.Cells(X, "G"), Rep.Cells(xx, "G")) = Me.TbDate.Value 'date
.Range(Rep.Cells(X, "H"), Rep.Cells(xx, "H")) = Me.CbCustomerName.Value 'customer
.Cells(X, "I") = Me.TbTotalNetPrice.Value 'balance
.Range(Rep.Cells(X, "T"), Rep.Cells(xx, "T")) = Users.Range("aw6").Value 'users
If Me.CbInvStore.Value = Data.Range("BF7") Then
.Cells(X, "Z") = Me.TbTotalNetPrice.Value 'balance
End If
If Me.CbInvStore.Value = Data.Range("BF8") Then
.Cells(X, "Y") = Me.TbTotalNetPrice.Value 'balance
End If
Inv.Unprotect ("0000")
Inv.Range("B9:M500").ClearContents
Inv.Range("B8:M" & 8 + fwo).Cells.Value = Me.ListBox1.List
.Range(.Cells(X, "J"), .Cells(xx, "S")) = Inv.Range("B9:K" & 8 + fwo).Value 'all product
.Range(.Cells(X, "W"), .Cells(xx, "X")) = Inv.Range("L9:M" & 8 + fwo).Value 'all product
.Protect Password:=("0000")
End With
'=========================================================================================
With Repc
.Select
.Unprotect ("8521")
AutoFilterMode = False
.Range("$B$8:$P$8").AutoFilter field:=1, Criteria1:=Me.CbInvStore.Value
.Range("$B$8:$P$8").AutoFilter field:=3, Criteria1:=Me.TbInvNo.Value
ss = .Range("f30000").End(xlUp).Row 'I need to change it to lastrow
.Range("$d$8:$r$8").AutoFilter
.Cells(ss, "F").Value = Me.CbCustomerName.Value 'customer
.Cells(ss, "B").Value = Me.CbInvStore.Value 'inv store
.Cells(ss, "C").Value = Me.TbDate.Value 'date
.Cells(ss, "K").Value = Me.CbPayment.Value
'.Cells(ss, "E").Value = inv.Range("e3").Value ' id
.Cells(ss, "O").Value = Me.CbMrName.Value 'mr
.Cells(ss, "P").Value = Users.Range("aw6").Value 'user
'CASE RETURN=====================
If Me.CbInvStore.Value = Data.Range("BF9") Or Me.CbInvStore.Value = Data.Range("BF10") Then
.Cells(ss, "I") = Me.TbTotalNetPrice.Value 'balance repcus
Else
.Cells(ss, "G") = Me.TbTotalNetPrice.Value 'balance repcus
End If
If Me.CbPayment.Value = "Cash" Then
.Cells(ss, "H") = Me.TbTotalNetPrice.Value 'balance repcus
Else
End If
.Protect Password:=("8521")
End With
'=========end case return ======
'======CASE PRMOTION=============
If Me.CbInvStore.Value = Data.Range("BF11") Or Me.CbInvStore.Value = Data.Range("BF12") Then
With Repc
.Unprotect ("8521")
.Range(.Cells(ss, "G"), .Cells(ss, "P")).ClearContents
.Cells(ss, "F") = Me.CbCustomerName.Value & " " & Data.[bb3] 'customer repcus offer
.Protect Password:=("0000")
End With
End If
'======end case prmotion======
'======== recall inv ========
Me.Btn_invs.Value = Me.CbInvStore.Value
Me.Btn_invn.Value = Me.TbInvNo.Value
CmdRecallInv_Click
'============================
sort_rep_customer
If Me.CreditBox.Value = True Then 'CbPayment = "Credit"
Call Credit
End If
confir = MsgBox(" Change Successfuly Saved", vbInformation, "Inventory Progarm")
Main.Select
1 Application.ScreenUpdating = True