[發問] 複製符合條件整列資料

b9208

複製符合條件整列資料
1. 條件：B欄值=ABC or QWE及C欄值=AA or BB及E欄值不等於空格
2. 將「工作表1」符合條件整列資料複製到「工作表2」
3. 「工作表2」資料依據A欄值排序，由小到大。
敬請指導
謝謝
AB.rar (8.89 KB)

下載次數: 26

2014-5-9 22:50

Hsieh

回復 1# b9208

1. Sub ex()
   
2. Dim A As Range, Rng As Range
   
3. With 工作表1
   
4. Set Rng = .[A1:G1]
   
5. For Each A In .Range("E:E").SpecialCells(xlCellTypeConstants)
   
6.   If (A.Offset(, -3) = "ABC" Or A.Offset(, -3) = "QWE") And (A.Offset(, -2) = "AA" Or A.Offset(, -2) = "BB") Then Set Rng = Union(Rng, A.Offset(, -4).Resize(, 7))
   
7. Next
   
8. With 工作表2
   
9. .Range(.[A3], .[A3].End(xlDown).Offset(, 6)).Clear
   
10. Rng.Copy .[A3]
    
11. .Range(.[A3], .[A3].End(xlDown).Offset(, 6)).Sort key1:=.[A3], Header:=xlYes
    
12. End With
    
13. End With
    
14. End Sub

複製代碼

b9208

回復 2# Hsieh
Dear Hsieh
非常感謝您的指導
執行上沒有問題
:)

dou10801

回復 2# Hsieh 請教版主,如果是[日期區段](工作表3),如何處理,感恩.

samwang

回復 4# dou10801

是這樣嗎? 請測試看看，謝謝

Sub test()
Dim Arr, T1, T2
With 工作表3
    Set Rng = .[A1:G1]
    T1 = .[j2]: T2 = .[k2]
    Arr = .Range(.[a1], .[g65536].End(3))
    For i = 2 To UBound(Arr)
        If Arr(i, 2) >= T1 And Arr(i, 2) <= T2 Then
        Set Rng = Union(Rng, .Cells(i, 1).Resize(, 7))
        End If
    Next
End With
With 工作表2
       .Range(.[A3], .[A3].End(xlDown).Offset(, 6)).Clear
       Rng.Copy .[A3]
End With
End Sub

dou10801

回復 5# samwang samwang前輩感恩,可以運作,其他延伸功能自行測試學習,謝謝.

hcm19522

回復 6# dou10801


    https://blog.xuite.net/hcm19522/twblog/590018193


https://blog.xuite.net/hcm19522/twblog/590018192

Andy2483

謝謝前輩發表此主題與範例
後學藉此帖練習陣列&字典
資料表:

下載 (42.64 KB)

2022-12-9 13:26

結果表:

下載 (25.15 KB)

2022-12-9 13:27

Sub TEST()
Dim Brr, C&, R&, T, V$(6), Y, N&
Set Y = CreateObject("Scripting.Dictionary")
Brr = 工作表1.UsedRange.Offset(1)
T = Split("ABC,QWE,AA,BB", ",")
For R = 1 To UBound(Brr)
   If (Brr(R, 2) = T(0) Or Brr(R, 2) = T(1)) And (Brr(R, 3) = T(2) Or Brr(R, 3) = T(3)) Then
      If Trim(Brr(R, 5)) <> "" Then
         N = N + 1
         For C = 1 To UBound(Brr, 2)
            V(C - 1) = Brr(R, C)
         Next
         Y(Brr(R, 1) & "|" & R) = V
      End If
   End If
Next
工作表2.UsedRange.Offset(3).Clear
With 工作表2.[A4].Resize(N, UBound(V))
   .Value = Application.Transpose(Application.Transpose(Y.ITEMS))
   .Sort key1:=.Item(1), Header:=xlNo
End With
Set Brr = Nothing
Set Y = Nothing
Erase T, V
End Sub

Andy2483

回復 2# Hsieh


    謝謝前輩
以下研習前輩心得註解,請再指導,謝謝

Option Explicit
Sub ex()
Dim A As Range, Rng As Range
'↑宣告變數
With 工作表1
'↑以下關於工作表1 程序
Set Rng = .[A1:G1]
'↑令Rng 是表一的[A1:G1]儲存格
For Each A In .Range("E:E").SpecialCells(xlCellTypeConstants)
'↑設順迴圈令A是 E欄非空格儲存格的其中一格,由前跑到後
  If (A.Offset(, -3) = "ABC" Or A.Offset(, -3) = "QWE") And (A.Offset(, -2) = "AA" Or A.Offset(, -2) = "BB") Then
  '↑如果A儲存格往左邊移3欄的儲存格值是"ABC",或儲存格值是"QWE",
  '而且A儲存格往左邊移2欄的儲存格值是"AA",或儲存格值是"BB"
     Set Rng = Union(Rng, A.Offset(, -4).Resize(, 7))
     '↑令Rng這儲存格變數是 原Rng儲存格集再添入 (A儲存格往左偏移4格開始擴展:
     '縱向不再擴展,只橫向往右擴展7欄)的儲存格範圍
  End If
Next
With 工作表2
'↑以下關於工作表2 程序
   .Range(.[A3], .[A3].End(xlDown).Offset(, 6)).Clear
   '↑工作表2 [A3]到 (從[A3]往下找到的最後一個有內容的儲存格)的儲存格集,
   '往右偏移6欄的儲存格清除
   Rng.Copy .[A3]
   '↑將Rng 儲存格集複製到 工作表2[A3]開始的範圍,
   '雖然目標儲存格集可能是間斷列,但複製於結果表會忽略空白的整列,往上遞補
   .Range(.[A3], .[A3].End(xlDown).Offset(, 6)).Sort key1:=.[A3], Header:=xlYes
   '↑工作表2 [A3]到 (從[A3]往下找到的最後一個有內容的儲存格)的儲存格集,
   '做排序!縱向,基準欄位是A欄,有標題列
End With
End With
End Sub

Andy2483

回復 8# Andy2483


    回復自己的粗心大意
Sub TEST()
Dim Brr, C&, R&, T, V$(6), Y, N&
'↑宣告變數(Brr,T,Y)是通用型變數,(C,R,N)是長整數,V是一維陣列V(0)~V(6)
Set Y = CreateObject("Scripting.Dictionary")
'↑令Y是字典
Brr = 工作表1.UsedRange.Offset(1)
'↑令Brr是陣列!倒入 工作表1有使用儲存格的最小方正區域往下偏移 1列儲存格 值
T = Split("ABC,QWE,AA,BB", ",")
'↑令T是以","符號拆解雙引號內的字串一維陣列
'索引號0:"ABC" ;1:"QWE" ;2:"AA" ;3:"BB"
For R = 1 To UBound(Brr)
'↑設外順迴圈!R從1到Brr陣列縱向最大列號
   If (Brr(R, 2) = T(0) Or Brr(R, 2) = T(1)) And (Brr(R, 3) = T(2) Or Brr(R, 3) = T(3)) Then
   '↑如果(迴圈列第2欄Brr陣列值是"ABC 或 迴圈列第2欄Brr陣列值是"QWE"),
   '而且(迴圈列第3欄Brr陣列值是"AA 或 迴圈列第3欄Brr陣列值是"BB")
      If Trim(Brr(R, 5)) <> "" Then
      '↑再如果迴圈列第5欄Brr陣列值是空字元
         N = N + 1
         '↑N數字變數累加 1
         For C = 1 To UBound(Brr, 2)
         '↑設內順迴圈!C從1到 Brr陣列橫向最大欄號
            V(C - 1) = Brr(R, C)
            '↑令Brr陣列的R迴圈列C迴圈欄值帶入V一維陣列相對位置裡
         Next
         Y(Brr(R, 1) & "|" & R) = V
         '↑令以R迴圈列第1欄Brr陣列值連接 "|" 符號,再連接R迴圈數 為key,
         'item是V一維陣列
      End If
   End If
Next
工作表2.UsedRange.Offset(3).Clear
'↑令 工作表2有使用儲存格的最小方正區域往下偏移 3列儲存格清除
With 工作表2.[A4].Resize(N, UBound(V) + 1)
'↑再次複習才檢查到欄數應該要加 1,因為UBound(V)指的不是陣列最大元素數!是最大索引號
'以下有關於 工作表2.[A4]向下擴展N列,向右擴展V一維陣列最大索引號數+1 的範圍儲存格
   .Value = Application.Transpose(Application.Transpose(Y.ITEMS))
   '↑擴展範圍儲存格的值以Y字典的item轉置後倒入
   .Sort key1:=.Item(1), Header:=xlNo
   '做排序!縱向,基準欄位是擴展區域的第 1欄,沒有標題列
End With
Set Brr = Nothing
Set Y = Nothing
Erase T, V
'↑釋放變數
End Sub

資料表:

下載 (34.82 KB)

2022-12-12 11:14

With 工作表2.[A4].Resize(N, UBound(V))

下載 (25.15 KB)

2022-12-12 11:14

With 工作表2.[A4].Resize(N, UBound(V) + 1)

下載 (25.55 KB)

2022-12-12 11:15