198188

回復 10# Andy2483


xA.Offset(1, 12).ClearContents:  Brr = xA
'↑令xA儲存格偏移下1列右12欄的區域儲存格內容清除,令Brr變數是以xA儲存格值帶入的二維陣列

這句清除内容，它是從第13欄(欄M) 到 第19欄 (欄S) 的内容清除，我需要的只是 第13欄欄M - 第15欄欄O, 我需要怎樣修正，才能讓他不把欄P - 欄S的資料清除？

Andy2483

回復 11# 198188

Intersect([1!M:O], xA.Offset(1, 12)).ClearContents
'↑令xA儲存格偏移下1列右12欄範圍與 M:O欄交集的區域儲存格內容清除

198188

回復 12# Andy2483


    可以了，謝謝！

Set xA = Range([1!G1], [1!A65536].End(3))
Intersect([1!M:O], xA.Offset(1, 12)).ClearContents: Brr = xA
Arr = [1!M1].Resize(UBound(Brr), 3)
[1!M1].Resize(UBound(Brr), 3) = Arr
另外如果我執行的工作表不固定名稱，怎樣修改為用activesheet?

shuo1125

回復 12# Andy2483
感謝Andy大熱情且專業~
也提供個xA.Offset(1, 12).Resize(, 3).ClearContents

Andy2483

回復 13# 198188

1.Set xA = Range([1!G1], [1!A65536].End(3))  改為
Set xA = Range(ActiveSheet.[G1], ActiveSheet.[A65536].End(3))

2.代碼裡面有[1!   的都要改

198188

回復 15# Andy2483


    明白，謝謝

Andy2483

回復 14# shuo1125

謝謝指教,這方法沒用過,又學到一招,之前都只會用intersect

198188

回復 17# Andy2483

剛剛我測試了幾次，不知道是怎麽回事，有的數據讀不出來。可否幫我看看附件，是否格式跟VBA 有衝突？

Andy2483

回復 18# 198188

Option Explicit
Sub TEST()
Dim Arr, Brr, Crr, V$, Z, i&, T$, TT$, A, xA As Range, N%
Set Z = CreateObject("Scripting.Dictionary")
Set xA = Range(ActiveSheet.[G1], ActiveSheet.[A65536].End(3))
xA.Offset(1, 12).Resize(, 3).ClearContents:  Brr = xA
For i = 2 To UBound(Brr)
   T = Format(Trim(Brr(i, 2)), "0000000"): V = Format(Val(Brr(i, 7)), "0000000"): TT = T & "/" & V
   Z(TT) = i
Next
Arr = ActiveSheet.[M1].Resize(UBound(Brr), 3)
A = Array(Range([KH!C1], [KH!A65536].End(3)), Range([KH!J1], [KH!H65536].End(3)), Range([KP!C1], [KP!A65536].End(3)), Range([KP!J1], [KP!H65536].End(3)))
For Each Crr In A
   Crr = Crr: N = N + 1
   For i = 3 To UBound(Crr)
      T = Format(Trim(Crr(i, 1)), "0000000"): V = Format(Val(Crr(i, 2)), "0000000"): TT = T & "/" & V
      If Z.Exists(TT) Then
         If Arr(Z(TT), 1) = "" Then
            Arr(Z(TT), 1) = Crr(1, 1)
            ElseIf InStr("/" & Arr(Z(TT), 1) & "/", "/" & Crr(1, 1) & "/") = 0 Then
            Arr(Z(TT), 1) = Arr(Z(TT), 1) & "/" & Crr(1, 1)
         End If
         Arr(Z(TT), N \ 3 + 2) = Crr(1, 3)
      End If
   Next
Next
ActiveSheet.[M1].Resize(UBound(Brr), 3) = Arr
End Sub

198188

回復 19# Andy2483


    不好意思，我上載錯了文件，這個才對。
部分地方無法讀取資料。