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

標題: [發問] 複製符合條件整列資料 [打印本頁]

作者: b9208 時間: 2014-5-9 22:51 標題: 複製符合條件整列資料

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

作者: Hsieh 時間: 2014-5-9 23:15

回復 1# b9208

Sub ex()
Dim A As Range, Rng As Range
With 工作表1
Set Rng = .[A1:G1]
For Each A In .Range("E:E").SpecialCells(xlCellTypeConstants)
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))
Next
With 工作表2
.Range(.[A3], .[A3].End(xlDown).Offset(, 6)).Clear
Rng.Copy .[A3]
.Range(.[A3], .[A3].End(xlDown).Offset(, 6)).Sort key1:=.[A3], Header:=xlYes
End With
End With
End Sub

複製代碼

作者: b9208 時間: 2014-5-11 06:41

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

作者: dou10801 時間: 2021-9-10 16:41

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

作者: samwang 時間: 2021-9-10 19:25

回復 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 時間: 2021-9-11 08:01

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

作者: hcm19522 時間: 2021-9-11 10:10

回復 6# dou10801

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

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

作者: Andy2483 時間: 2022-12-9 13:27

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

結果表:
[attach]35579[/attach]

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 時間: 2022-12-12 09:50

本帖最後由 Andy2483 於 2022-12-12 09:56 編輯

回復 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 時間: 2022-12-12 11:10

本帖最後由 Andy2483 於 2022-12-12 11:23 編輯

回復 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

資料表:
[attach]35589[/attach]

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

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

作者: Andy2483 時間: 2022-12-14 16:37

練習用兩個二維陣列,一個一維陣列處理

Sub TEST_20221214()
Dim Brr, C&, R&, T, Crr, N&
Brr = 工作表1.UsedRange.Offset(1)
ReDim Crr(1 To UBound(Brr), 1 To UBound(Brr, 2))
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)
         Crr(N, C) = Brr(R, C)
      Next
   End If
End If
Next
工作表2.UsedRange.Offset(3).Clear
With 工作表2.[A4].Resize(N, UBound(Crr, 2))
.Value = Crr
.Sort key1:=.Item(1, 1), Header:=2, Orientation:=xlTopToBottom
End With
Set Brr = Nothing
Set Crr = Nothing
Erase T
End Sub

歡迎光臨麻辣家族討論版版 (http://forum.twbts.com/)