[發問] 有關listbox 問題?

我肥人

各位高手，Form.xlsm本身可以正常運作，但現在表單需加入更多欄位(testbox1-9)，便無法使用，希望高手指點，謝謝!!

Andy2483

回復 1# 我肥人


    謝謝前輩發表此主題與範例
後學練習陣列與字典搭配輸入窗的 新增 資料作業的解決方案,請前輩參考

執行:

下載 (88.85 KB)

2023-3-3 15:06

Option Explicit
Sub 新增()
Dim Brr, A, Y, i&, B As Range
Set Y = CreateObject("Scripting.Dictionary")
Brr = [A6:Q6]
For i = 1 To UBound(Brr, 2)
   A = InputBox(Brr(1, i), "請輸入", Cells(Rows.Count, i).End(3))
   If A = "//" Or StrPtr(A) = 0 Then Exit Sub Else: Y(Brr(1, i)) = A
Next
Set B = Cells(Rows.Count, 1).End(3).Item(2).Resize(1, Y.Count)
B.Value = Y.Items: Application.Goto B
End Sub

Andy2483

回復 1# 我肥人


    謝謝前輩發表此主題與範例
後學練習陣列以輔助表的方式 做資料 修改 作業的解決方案,請前輩參考

執行方式:
1.選取資料表其中一列或一格後按修改鈕:

下載 (92.27 KB)

2023-3-9 13:02

1.1.執行結果:

下載 (86.02 KB)

2023-3-9 13:05

2.修改資料後請切換回資料表 "Worksheet":

下載 (95.23 KB)

2023-3-9 13:07

3.完成修改:

下載 (92.5 KB)

2023-3-9 13:08

form_20230309_1.zip (40.77 KB)

下載次數: 7

2023-3-9 13:08

Option Explicit
Sub 編輯修改模式()
Dim Arr, Brr, R&
Application.DisplayAlerts = False
If Selection.Rows.Count > 1 Then MsgBox "每次只能修改一列資料": Exit Sub
If Selection.Row <= 6 Or Cells(Selection.Row, 1) = "" Then
   MsgBox "先選取修改列": Exit Sub
End If
R = Selection.Row: Arr = [A6:Q6]: Brr = Range(Cells(R, "A"), Cells(R, "Q"))
Rows(R).Font.ColorIndex = 1
On Error Resume Next
Sheets("Modify").Delete
On Error GoTo 0
Worksheets.Add(After:=Sheets(Sheets.Count)).Name = "Modify"
[A2].Resize(UBound(Arr, 2), 1) = Application.Transpose(Arr)
[A2].Resize(UBound(Arr, 2), 1).Interior.ColorIndex = 35
[B2].Resize(UBound(Brr, 2), 1) = Application.Transpose(Brr)
[A1] = "項目": [B1] = "原值": [C1] = "新值"
Cells.Font.Size = 14
[A:B].EntireColumn.AutoFit
[C:C].ColumnWidth = [B:B].ColumnWidth * 2
ActiveSheet.UsedRange.Borders.LineStyle = xlContinuous
[D1] = R
ActiveSheet.Protection.AllowEditRanges.Add Title:="範圍1", Range:=[C2].Resize(UBound(Brr, 2), 1)
ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True, Password:="0000"
Sheets("Worksheet").Protect DrawingObjects:=True, Contents:=True, Scenarios:=True, Password:="0000"
End Sub
=============================================
Sub 修改資料帶入資料表()
Dim Arr, R&, i&
If Sheets("Modify").Cells(Rows.Count, "C").End(3).Row = 1 Then MsgBox "沒有修改": Exit Sub
Arr = Sheets("Modify").UsedRange
R = Sheets("Modify").[D1]
For i = 2 To UBound(Arr)
   If Trim(Arr(i, 3)) <> "" Then
      Sheets("Worksheet").Cells(R, i - 1) = Trim(Arr(i, 3))
      Sheets("Worksheet").Cells(R, i - 1).Font.ColorIndex = 5
   End If
Next
End Sub
======================================
Private Sub Worksheet_Activate()
ActiveSheet.Unprotect "0000"
Call 修改資料帶入資料表

Application.DisplayAlerts = False
Sheets("Modify").Delete
End Sub

Andy2483

回復 2# Andy2483


    謝謝論壇,謝謝各位前輩
後學複習此帖心得註解如下,請各位前輩指教

Option Explicit
Sub 新增()
Dim Brr, A, Y, i&, B As Range
'↑宣告變數:(Brr,A,Y)是通用型變數,i是長整數變數,B是儲存格變數
Set Y = CreateObject("Scripting.Dictionary")
'↑令Y這通用型變數是 字典
Brr = [A6:Q6]
'↑令Brr這通用型變數是 二維陣列!以[A6:Q6]儲存格值帶入
For i = 1 To UBound(Brr, 2)
'↑設順迴圈!i從1到 Brr陣列橫向最大索引欄號
   A = InputBox(Brr(1, i), "請輸入", Cells(Rows.Count, i).End(3))
   '↑令A這通用型變數是 Application.InputBox 方法回傳字串值
   If A = "//" Or StrPtr(A) = 0 Then Exit Sub Else: Y(Brr(1, i)) = A
   '↑如果A變數是 "//",或A變數經StrPtr函數回傳值是 0!
   '就結束程式執行,否則令第1列i迴圈欄Brr陣列值為key,A變數是item納入Y字典
Next
Set B = Cells(Rows.Count, 1).End(3).Item(2).Resize(1, Y.Count)
'↑令B這儲存格變數是(A欄最後有內容儲存格的下一個儲存格)擴展儲存格範圍,
'擴展儲存格範圍:向右Y字典key數量欄
B.Value = Y.Items: Application.Goto B
'↑令B變數值是 Y字典的item值:令儲存格游標選取在 B變數上
End Sub