Option Explicit
Sub 加入主表格()
Dim Crr(1 To 100, 1 To 6), Q, i&, j%, A, n&
Dim sh1 As Worksheet, sh2 As Worksheet, Frng As Range
For Each Q In Worksheets
If Q.[F1] = "建議廠牌" Then Set sh1 = Q
If Q.[G3] = "建議廠牌" Then Set sh2 = Q
Next
A = Array(1, 2, 4, 5, 6)
With sh1: .Activate
If .AutoFilter Is Nothing Then
.[A2].AutoFilter
With ActiveWindow
.FreezePanes = False: .SplitRow = 1: .FreezePanes = True
End With
End If
If .[B65536].End(3).Row = 1 Then MsgBox "沒有資料": Exit Sub
For i = 2 To .[B65536].End(3).Row
If Rows(i).EntireRow.Hidden = True Then GoTo i02
n = n + 1
For j = 0 To 4
Crr(n, A(j)) = Cells(i, j + 2)
Next
i02: Next
End With
With sh2.[B65536].End(3)(2).Resize(n, 6)
.Value = Crr
sh2.Activate
.Select
End With
Set sh1 = Nothing: Set sh2 = Nothing: Set Frng = Nothing: Erase Crr
End Sub
Sub 清除項目()
Dim Q
For Each Q In Worksheets
If Q.[G3] = "建議廠牌" Then Q.UsedRange.Offset(3, 0).EntireRow.Delete: Exit Sub
Next
End Sub作者: sschristy 時間: 2023-10-6 16:40
Public wst As String
Public j As Integer
Sub test()
Dim i As Integer
For i = 4 To 9999
If (Sheets("主表格").Range("A" & i) = "" And Sheets("主表格").Range("B" & i) = "") Then
Sheets("主表格").Range("B" & i) = Sheets(wst).Range("B" & j)
Sheets("主表格").Range("C" & i) = Sheets(wst).Range("C" & j)
Sheets("主表格").Range("E" & i) = Sheets(wst).Range("D" & j)
Sheets("主表格").Range("F" & i) = Sheets(wst).Range("E" & j)
Sheets("主表格").Range("G" & i) = Sheets(wst).Range("F" & j)
Exit For
Else
End If
Next i
Sheets("主表格").Activate
End Sub
------------------------------------------------------------------------
Private Sub CommandButton1_Click()
wst = "參考表1"
j = ActiveCell.Row
Application.Run "Module1.test"
End Sub
-------------------------------------------------------
前輩大大，這是按鈕內的程式碼，目前的方式是被選取到的那一行就會自動加入到主表格
但想要更改為可以批次加入，不知有沒有好方法，謝謝作者: Andy2483 時間: 2023-10-11 11:57
複習,修正與註解
Option Explicit
Sub 加入主表格()
Dim Crr(1 To 100, 1 To 6), Q, i&, j%, A, n&
'↑宣告Crr變數是二維陣列縱向範圍1到 100,橫向範圍從1到 6
'(Q,A)是通用型變數,(i,n)是長整數,j是短整數
Dim sh1 As Worksheet, sh2 As Worksheet, Frng As Range
'↑宣告(sh1,sh2)是工作表變數,Frng是儲存格變數
For Each Q In Worksheets
'↑設逐項迴圈!令Q是活頁簿中的工作表
If Q.[F1] = "建議廠牌" Then Set sh1 = Q
'↑如果工作表中的[F1]儲存格值是"建議廠牌"!就令sh1變數是工作表Q
If Q.[G3] = "建議廠牌" Then Set sh2 = Q
'↑如果工作表中的[G3]儲存格值是"建議廠牌"!就令sh2變數是工作表Q
Next
A = Array(1, 2, 4, 5, 6)
'↑令A變數是一維陣列,0~4索引號陣列值依序是(1, 2, 4, 5, 6)
With sh1: .Activate
'↑以下是關於工作表sh1的程序
'↑令激活該工作表
If .AutoFilter Is Nothing Then
'↑如果工作表沒有篩選的功能?
.[A2].AutoFilter
'↑令該表從該表[A2]儲存格建立篩選功能
With ActiveWindow
'↑以下是關於視窗的程序
.FreezePanes = False: .SplitRow = 1: .FreezePanes = True
'↑令凍結視窗解除,第1列分割視窗:令凍結視窗
End With
End If
If .[B65536].End(3).Row = 1 Then MsgBox "沒有資料": Exit Sub
'↑如果該表B欄最後有內容儲存格列號是1? True就跳出提視窗,結束程式執行
For i = 2 To .[B65536].End(3).Row
'↑設順迴圈!i從2到該表B欄最後有內容儲存格列號
If .Rows(i).EntireRow.Hidden = True Then GoTo i02
'↑如果該列是隱藏的!就跳到標示i02位置繼續執行
n = n + 1
'↑令n變數累加1
For j = 0 To 4
'↑設順迴圈!j從0到 4
Crr(n, A(j)) = Cells(i, j + 2)
'↑令n變數列(j變數A陣列值)欄的Crr陣列值是i變數列j變數+2欄儲存格值
Next
i02: Next
End With
With sh2.[B65536].End(3)(2).Resize(n, 6)
'↑以下是關於工作表sh2從下往上找到的B欄第1個空白格向下擴展n變數列,
'向右擴展6欄儲存格的程序
.Value = Crr
'↑令儲存格值以Crr陣列值帶入
sh2.Activate
'↑令激活工作表
.Select
'↑令選取該範圍儲存格
End With
Set sh1 = Nothing: Set sh2 = Nothing: Set Frng = Nothing: Erase Crr
'↑令釋放變數
End Sub
Sub 清除項目()
Dim Q
For Each Q In Worksheets
If Q.[G3] = "建議廠牌" Then Q.UsedRange.Offset(3, 0).EntireRow.Delete: Exit Sub
Next
'↑令結果表清除第3列以後的資料(含)
End Sub作者: Andy2483 時間: 2023-10-14 12:07
'以下是參考表1 選取多列 批次加入的建議方案
Private Sub CommandButton1_Click()
Dim Q, A(10000), i&, n&
wst = "參考表1"
For Each Q In Split(Selection.Cells.EntireRow.Address(0, 0), ",")
For i = 0 To -Evaluate(Replace(Q, ":", "-"))
A(n) = Val(Q) + i
n = n + 1
Next
Next
For i = 0 To n - 1
j = A(i)
Application.Run "Module1.test"
Next
Sheets("主表格").Activate
End Sub
[attach]36903[/attach][attach]36903[/attach]
以下是目前的程式碼，只能一次刪一列
Private Sub CommandButton2_Click()
Dim b As Integer
b = (ActiveCell.Row)
Range("A" & b & ":G" & b).ClearContents
End Sub作者: Andy2483 時間: 2023-10-24 07:22
Private Sub CommandButton2_Click()
Dim xA As Range, xB As Range, xI As Range
Set xA = Range([A1], ActiveSheet.UsedRange)
Set xB = [A:G]
Set xI = Intersect(xA, xB)
xI.Offset(3, 0).ClearContents
End Sub
Private Sub CommandButton2_Click()
Dim xA As Range, xB As Range, xI As Range
'↑宣告(xA,xB,xI)各是儲存格變數
Set xA = Range([A1], ActiveSheet.UsedRange)
'↑令xA這儲存格變數是涵蓋[A1]儲存格與此表已使用儲存格,
'涵蓋這區間的最小方正範圍儲存格
Set xB = [A:G]
'↑令xB這儲存格變數是[A:G]儲存格
Set xI = Intersect(xA, xB)
'↑令xI這儲存格變數是 xA與xB變數交集的儲存格
xI.Offset(3, 0).ClearContents
'↑令xI變數往下偏移3列的這新範圍儲存格清除其內容
End Sub作者: sschristy 時間: 2023-10-25 10:14
Private Sub CommandButton2_Click()
Dim Q, A$, i&, n&, xI As Range, Brr, xA As Range, xB As Range
Set xA = Selection.Cells: Set xB = ActiveSheet.UsedRange
If xA.EntireRow.Count > xB.Rows.Count Then Set xA = Intersect(xA, xB)
If xA Is Nothing Then Exit Sub
Set xI = Intersect(Range([A1], xB), [A:G]): Brr = xI
For Each Q In Split(xA.EntireRow.Address(0, 0), ",")
For i = Split(Q, ":")(0) To Split(Q, ":")(1)
A = IIf(A = "", "/" & Val(i) & "/", A & Val(i) & "/")
Next
Next
For i = 4 To xI.Rows.Count
If InStr(A, "/" & i & "/") Then GoTo i01 Else n = n + 1
For j = 1 To UBound(Brr, 2): Brr(n, j) = Brr(i, j): Next
i01: Next
xI.Offset(3, 0).ClearContents
If n = 0 Then Exit Sub
[A4].Resize(n, UBound(Brr, 2)) = Brr
End Sub作者: Andy2483 時間: 2023-10-25 14:56
以下另一方法,請前輩參考
Private Sub CommandButton2_Click()
Dim xU As Range, xA As Range, xB As Range
Set xA = Selection.Cells: Set xB = ActiveSheet.UsedRange.Offset(3)
Set xU = Union(xA, xB)
If xU.Count <> xB.Count Then Exit Sub
Intersect(xA.EntireRow, [A:G]).Delete Shift:=xlUp
End Sub作者: rtyfghvbn520 時間: 2023-10-29 12:34
With sh2.[B65536].End(3)(2).Resize(n, 6)
.Value = Crr
sh2.Activate
.Select
With .Cells(.Count + 1)
.Value = Now: .Font.ColorIndex = 2
'↑令B欄最後加一格內容為 當下時間的儲存格,令字色為白色
'也可以令儲存格內容為空白字元.Value = " "
'這樣的方式比較不會導致篩選功能資料不完整(空列易導致資料中斷)
End With
End With
