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 時間: 2023-3-9 13:10
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 時間: 2023-3-14 16:27
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
