麻辣家族討論版版 - Powered by Discuz! Board

Dim Ar()
Private Sub UserForm_Initialize()
ComboBox1.RowSource = Range("L2:L5").Address
ComboBox2.RowSource = Range("N2:N6").Address
ComboBox3.RowSource = Range("M2:M4").Address
Ar = Array(TextBox1, ComboBox1, ComboBox2, TextBox2, TextBox3, ComboBox3, TextBox4, TextBox5, TextBox6)
End Sub
Private Sub CommandButton1_Click()
Dim nrow As Integer
With Worksheets("sheet1")
nrow = .Range("A" & .Rows.Count).End(xlUp).Row + 1
'由工作表欗底部最後一個列,往上到第一個有資料的列號+1
.Range("a" & nrow).Resize(, UBound(Ar) + 1) = Ar
End With
End Sub

複製代碼

Dim Ar() '模組的最頂端宣告此模組的程序可用之變數

複製代碼

Sub Ex()
Dim I As Integer
With ActiveSheet
.Cells(1, .Columns.Count).End(xlToLeft).Select
'第1列由最右邊(最後一欗: Columns.Count ),往左有資料的儲存格
End With
End Sub

複製代碼

Option Explicit
Option Base 1
Dim Ar(), Sh As Worksheet
Private Sub CommandButton1_Click()
Dim Nrow As Integer
If 資料檢查 = True Then Exit Sub
Nrow = 資料數
If MsgBox("確定新增第 " & Nrow & " 資料", vbYesNo) = vbNo Then Exit Sub
Ar(1).Value = Nrow
With Sh.Range("a" & Ar(1) + 1)
.Resize(, UBound(Ar)) = Ar
.Resize(, UBound(Ar)) = .Resize(, UBound(Ar)).Value
'.Cells(1, "i") = "=sum(r2c4:rc4)+sum(r2c5:rc5)-(sum(r2c7:rc7)+sum(r2c8:rc8))" '庫存差額
'(台北出貨1 + 台北出貨2) - 業務員的 (進貨數量1+進貨數量2) = 庫存差額 ** 怪怪的 **
'***************************************************************************************
' 庫存差額 : 應該是業務員的 (進貨數量1+進貨數量2) - (台北出貨1 + 台北出貨2)
.Cells(1, "i") = "=sum(r2c7:rc7)+sum(r2c8:rc8)-(sum(r2c4:rc4)+sum(r2c5:rc5))" '庫存差額
'***************************************************************************************
.Cells(1, "i").Value = .Cells(1, "i") '轉化公式 = 計算後的數值
End With
End Sub
Private Sub CommandButton2_Click()
Dim I As Integer
For I = 1 To UBound(Ar)
Ar(I).Value = ""
Next
End Sub
Private Sub CommandButton3_Click()
Dim I As Integer, Rng As Range
With Sh
.AutoFilterMode = False
For I = 1 To UBound(Ar)
If Ar(I) <> "" Then .Range("A1").AutoFilter I, Ar(I)
Next
.Range("A:i").SpecialCells(xlCellTypeVisible).Copy .Range("AA1")
.AutoFilterMode = False
Set Rng = .Range("AA1").CurrentRegion.Offset(1)
End With
ListBox1.RowSource = Rng.Address
End Sub
Private Sub CommandButton4_Click()
Dim s, E As Range, I As Integer
With ListBox1
If .ListIndex = -1 Then MsgBox "沒有選擇!!": Exit Sub
s = Application.Index(Application.Transpose(Application.Transpose(.List)), IIf(.ListCount = 1, 0, 1))
If Join(s, "") = "" Then MsgBox "沒有資料!!": Exit Sub
s = Application.Index(Application.Transpose(Application.Transpose(.List)), IIf(.ListCount = 1, 0, .ListIndex + 1))
End With
s = Join(s, ",") 'S: 結合控制項的字串 [ 自動編號序號公司產品名稱台北出貨1台北出貨2業務員進貨數量1進貨數量2庫存差額 ]
With Sh
For Each E In .Range("A1", .Range("A1").End(xlDown)).Resize(, 9).Rows '整列:[ 自動編號......庫存差額 ]
If s = Join(Application.Transpose(Application.Transpose(E)), ",") Then
If MsgBox(Join(Application.Transpose(Application.Transpose(E.Value)), ","), vbYesNo, "刪除列") = vbYes Then
處裡刪除整列 E
End If
End If
Next
End With
CommandButton3_Click '重新查詢
End Sub
Private Sub CommandButton5_Click()
End
End Sub
Private Sub UserForm_Initialize()
Ar = Array(TextBox1, ComboBox1, ComboBox2, TextBox2, TextBox3, ComboBox3, TextBox4, TextBox5)
Set Sh = Worksheets("sheet1")
With Sh
ComboBox1.RowSource = Sh.Range("L2:L5").Address
ComboBox2.RowSource = Sh.Range("N2:N6").Address
ComboBox3.RowSource = Sh.Range("M2:M4").Address
End With
With ListBox1
.ColumnHeads = True
.ColumnCount = 9
End With
End Sub
Private Sub 處裡刪除整列(Rng As Range)
Dim I As Integer
Rng.Delete xlUp
I = 資料數
If I > 1 Then
With Sh
With .Range("a2:a" & I)
.Value = "=row()-1"
.Value = .Value
End With
With .Range("i2:i" & I)
.Value = "=sum(r2c7:rc7)+sum(r2c8:rc8)-(sum(r2c4:rc4)+sum(r2c5:rc5))" '庫存差額
.Value = .Value
End With
End With
End If
End Sub
Private Function 資料數() As Integer
資料數 = Application.CountA(Sh.Range("A:A")) '自動編號
End Function
Private Function 資料檢查() As Boolean
Dim s As String, E As Range, I As Integer, ii
With Sh
For I = 2 To UBound(Ar)
ii = 10 - Len(Sh.Cells(1, I))
If I = 2 Or I = 3 Or I = 6 Then
If Ar(I).ListIndex = -1 Then s = s & IIf(s = "", "", vbLf) & Sh.Cells(1, I) + Space(ii) & vbTab & Ar(I)
Else
If Not IsNumeric(Ar(I)) And Ar(I) <> "" Then s = s & IIf(s = "", "", vbLf) & Sh.Cells(1, I) + Space(ii) & vbTab & Ar(I)
End If
Next
If s <> "" Then
資料檢查 = True: MsgBox s, , "資料有誤!!": Exit Function
ElseIf s = "" And Ar(4) & Ar(5) & Ar(7) & Ar(8) = "" Then
資料檢查 = True: MsgBox "出貨進貨沒有數量", , "資料有誤!!": Exit Function
End If
s = "," & Join(Ar, "")
s = Replace(s, "," & Ar(1), "") 'S: 結合控制項的字串 [ 序號公司產品名稱台北出貨1台北出貨2業務員進貨數量1進貨數量2 ]
For Each E In .Range("B1", .Range("B1").End(xlDown)).Resize(, 7).Rows
If s = Join(Application.Transpose(Application.Transpose(E.Value)), "") Then
MsgBox Replace(Join(Ar, ","), Ar(1) & ",", "") & vbLf & "已存在為第" & E.Row - 1 & " 筆資料不可新增"
資料檢查 = True
Exit Function
End If
Next
End With
End Function

複製代碼

Private Sub CommandButton1_Click()
Dim Nrow As Integer
If 資料檢查 = True Then Exit Sub
Nrow = 資料數
If MsgBox("確定新增第 " & Nrow & " 資料", vbYesNo) = vbNo Then Exit Sub
ar(1).Value = Nrow
With Sh.Range("a" & ar(1) + 1)
.Resize(, UBound(ar)) = ar
.Resize(, UBound(ar)) = .Resize(, UBound(ar)).Value
'.Cells(1, "i") = "=sum(r2c7:rc7)+sum(r2c8:rc8)-(sum(r2c4:rc4)+sum(r2c5:rc5))" '庫存差額
'.Cells(1, "i") = "=sum(r2c4:rc4)+sum(r2c5:rc5)-(sum(r2c7:rc7)+sum(r2c8:rc8))" '庫存差額
.Cells(1, "i") = "=(rc4+rc5)-(rc7+rc8)" '庫存差額公式
' .Cells(1, "i").Value = .Cells(1, "i") '轉化公式 = 計算後的數值
End With
End Sub

複製代碼

Private Sub 處裡刪除整列(Rng As Range)
Dim I As Integer
Rng.Delete xlUp
I = 資料數
If I > 1 Then
With Sh
With .Range("a2:a" & I)
.Value = "=row()-1"
.Value = .Value
End With
With .Range("i2:i" & I)
'.Value = "=sum(r2c7:rc7)+sum(r2c8:rc8)-(sum(r2c4:rc4)+sum(r2c5:rc5))" '庫存差額
.Value = "=(rc4+rc5)-(rc7+rc8)" '庫存差額公式
' .Value = .Value ''庫存差額數值
End With
End With
End If
End Sub

複製代碼

'*** UserForm2 表單模組 *********
Option Base 1
Dim ar(), Sh(1 To 2) As Worksheet
Private Sub UserForm_Initialize()
ar = Array(TextBox1, ComboBox1, TextBox2, TextBox3, TextBox4, TextBox5, TextBox6, ComboBox2) '這裡有修改控制項,事正確的
Set Sh(1) = Worksheets("Sheet1")
Set Sh(2) = Worksheets("輸入數值")
With Sh(2)
ComboBox1.RowSource = Sh(1).Range("L2:L5").Address ' 整合用sheet1的下拉式
ComboBox2.RowSource = Sh(1).Range("M2:M4").Address
End With
With ListBox1
.ColumnHeads = True
.ColumnCount = 8
End With
End Sub
Private Function 資料檢查() As Boolean
Dim s As String, E As Range, I As Integer, ii
With Sh
For I = 2 To UBound(ar)
ii = 10 - Len(Sh.Cells(1, I))
If I = 2 Or I = 3 Or I = 6 Then 'I= ?? ComboBox 及 ListBox 才有.ListIndex的屬性
'*** 這裡沒改:TextBox1 沒有.ListIndex的屬性 ****
If ar(I).ListIndex = -1 Then s = s & IIf(s = "", "", vbLf) & Sh.Cells(1, I) + Space(ii) & vbTab & ar(I)
Else
If Not IsNumeric(ar(I)) And ar(I) <> "" Then s = s & IIf(s = "", "", vbLf) & Sh.Cells(1, I) + Space(ii) & vbTab & ar(I)
'*** 這裡也要改 ***********
End If
Next
If s <> "" Then
資料檢查 = True: MsgBox s, , "資料有誤!!": Exit Function
ElseIf s = "" And ar(4) & ar(5) & ar(7) & ar(8) = "" Then '*** 這裡也要改 ***********
資料檢查 = True: MsgBox "出貨進貨沒有數量", , "資料有誤!!": Exit Function
End If
s = "," & Join(ar, "")
s = Replace(s, "," & ar(1), "") 'S: 結合控制項的字串 [ 自動編號序號公司配額筆數數值應付已付(進貨數量1+進貨數量2)業務員 ]
For Each E In .Range("B1", .Range("B1").End(xlDown)).Resize(, 7).Rows
If s = Join(Application.Transpose(Application.Transpose(E.Value)), "") Then
MsgBox Replace(Join(ar, ","), ar(1) & ",", "") & vbLf & "已存在為第" & E.Row - 1 & " 筆資料不可新增"
資料檢查 = True
Exit Function
End If
Next
End With
End Function

複製代碼

Private Sub CommandButton3_Click() '查詢
Dim I As Integer, Rng As Range
With Sh(2)
.AutoFilterMode = False
For I = 1 To UBound(ar)
If ar(I) <> "" Then .Range("A1").AutoFilter I, ar(I)
Next
'.Range("A:i").SpecialCells(xlCellTypeVisible).Copy .Range("AA1") ->'Sh(2)的 AA1->AI欗
'******* .ColumnCount = 8 'ListBox1設定8欗所以改成如下********
.Range("A:H").SpecialCells(xlCellTypeVisible).Copy .Range("AA1")
.AutoFilterMode = False
Set Rng = .Range("AA1").CurrentRegion.Offset(1) 'Sh(2)的 AA1->AH :AI欗的資料,*****AI欗須先刪掉(手動)*****
End With
ListBox1.RowSource = Rng.Address
End Sub
Private Sub CommandButton4_Click() '刪除整列
Dim s, E As Range, I As Integer
With ListBox1
If .ListIndex = -1 Then MsgBox "沒有選擇!!": Exit Sub
s = Application.Index(Application.Transpose(Application.Transpose(.List)), IIf(.ListCount = 1, 0, 1))
If Join(s, "") = "" Then MsgBox "沒有資料!!": Exit Sub
s = Application.Index(Application.Transpose(Application.Transpose(.List)), IIf(.ListCount = 1, 0, .ListIndex + 1))
'S= ListIndex的選擇.ListIndex 那一列的資料,會比 Resize(, 8)多一欗.
'當
'->.Range("A:i").SpecialCells(xlCellTypeVisible).Copy .Range("AA1") ->'Sh(2)的 AA1->AI欗
'-> For Each E In .Range("A1", .Range("A1").End(xlDown)).Resize(, 8).Rows '整列:[ 自動編號......業務員 ]
End With
s = Join(s, ",") 'S: 結合控制項的字串 [ 自動編號序號公司配額筆數數值應付已付(進貨數量1+進貨數量2)業務員 ]
With Sh(2)
For Each E In .Range("A1", .Range("A1").End(xlDown)).Resize(, 8).Rows '整列:[ 自動編號......業務員 ]
Debug.Print s
Debug.Print Join(Application.Transpose(Application.Transpose(E)), ",")
If s = Join(Application.Transpose(Application.Transpose(E)), ",") Then
If MsgBox(Join(Application.Transpose(Application.Transpose(E.Value)), ","), vbYesNo, "刪除列") = vbYes Then
處裡刪除整列 E
End If
End If
Next
End With
CommandButton3_Click '重新查詢
End Sub

複製代碼

Private Sub CommandButton3_Click() 'UserForm2的查詢程式碼
Dim I As Integer, Rng As Range
With Sh(2)
.Range("AA1").CurrentRegion = "" '加這行 UserForm2表單執行一次後可不需這程式碼
.AutoFilterMode = False
For I = 1 To UBound(ar)
If ar(I) <> "" Then .Range("A1").AutoFilter I, ar(I)
Next
.Range("A:h").SpecialCells(xlCellTypeVisible).Copy .Range("AA1")
'原本是 .Range("A:i").SpecialCells(xlCellTypeVisible).Copy .Range("AA1")
.AutoFilterMode = False
Set Rng = .Range("AA1").CurrentRegion.Offset(1)
End With
ListBox1.RowSource = Rng.Address
End Sub

複製代碼

Private Sub CommandButton3_Click()
Dim y
Dim Joken3 As String
Joken3 = "小王"
If Joken3 = "" Then Exit Sub
With Sheets("進貨表")
'若在篩選中，先解除顯示全部
If .FilterMode Then .ShowAllData
'以〔第5欄．業務員〕進行篩選
.[A1].AutoFilter Field:=5, Criteria1:=Joken3
'取得篩選後，最後一筆資料的〔列號〕
y = .[A65536].End(xlUp).Row
'進行貼轉資料
.Range("A1:F" & y).Copy [小王總庫存!A1]
'再恢復全表
.ShowAllData
'取消[自動篩選] 下拉箭號
.[A1].AutoFilter
MsgBox [SUM(小王總庫存!F:F)] '篩選後的加總
End With
Beep
End Sub

複製代碼

Option Explicit
Private Sub Worksheet_Activate() '活頁簿: 選擇工作表的預設事件
'進階篩選公司名稱 'Columns.Count ->工作表的總欗數 ->最後一欗
Range("B:B").AdvancedFilter xlFilterCopy, , Cells(1, Columns.Count), True
With Range("I2").Validation '資料的驗證清單
.Delete
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
xlBetween, Formula1:="=" & Range(Cells(2, Columns.Count).Address, Cells(1, Columns.Count).End(xlDown).Address).Address
.IgnoreBlank = True
End With
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
Application.EnableEvents = False
If Target.Address(0, 0) = "I2" Then
Range("J2") = [SUMIF(B:B,I2,D:D)] '工作表的函數在 VBA用中括號計算 [ <- 工作表的函數 -> ]
Range("K2") = [SUMIF(B:B,I2,F:F)]
End If
Application.EnableEvents = True
End Sub

複製代碼

Private Function 資料檢查() As Boolean
Dim s As String, E As Range, I As Integer, ii
With Sh
For I = 2 To UBound(ar)
ii = 10 - Len(Sh.Cells(1, I))
If I = 2 Or I = 3 Or I = 6 Then
If ar(I).ListIndex = -1 Then s = s & IIf(s = "", "", vbLf) & Sh.Cells(1, I) + Space(ii) & vbTab & ar(I)
Else
If Not IsNumeric(ar(I)) And ar(I) <> "" Then s = s & IIf(s = "", "", vbLf) & Sh.Cells(1, I) + Space(ii) & vbTab & ar(I)
End If
Next
If s <> "" Then
資料檢查 = True: MsgBox s, , "資料有誤!!": Exit Function
ElseIf s = "" And ar(4) & ar(5) & ar(7) & ar(8) = "" Then
資料檢查 = True: MsgBox "出貨進貨沒有數量", , "資料有誤!!": Exit Function
End If
'******** 以下為檢查是否有相同的資料如不需要可刪除 ****************
s = "," & Join(ar, "")
s = Replace(s, "," & ar(1), "") 'S: 結合控制項的字串 [ 序號公司產品名稱台北出貨1台北出貨2業務員進貨數量1進貨數量2 ]
For Each E In .Range("B1", .Range("B1").End(xlDown)).Resize(, 7).Rows
If s = Join(Application.Transpose(Application.Transpose(E.Value)), "") Then
MsgBox Replace(Join(ar, ","), ar(1) & ",", "") & vbLf & "已存在為第" & E.Row - 1 & " 筆資料不可新增"
資料檢查 = True
Exit Function
End If
Next
'******************************************************************************
End With
End Function

複製代碼