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

Sub 擷取()
Dim Rng As Range, aRng As Range, bRng As Range
With Sheets("統計")
.Range("B2:C" & .Cells(Rows.Count, 1).End(xlUp).Row).ClearContents
For Each Rng In .Range("A2:A" & .Cells(Rows.Count, 1).End(xlUp).Row)
Set aRng = Sheets("甲").Columns(1).Find(Rng.Value, LookIn:=xlFormulas, LookAt:=xlWhole, SearchDirection:=2)
Set bRng = Sheets("乙").Columns(1).Find(Rng.Value, LookIn:=xlFormulas, LookAt:=xlWhole, SearchDirection:=2)
If Not aRng Is Nothing Then Rng.Offset(, 1) = aRng.Offset(, 11)
If Not aRng Is Nothing Then Rng.Offset(, 2) = bRng.Offset(, 11)
Next
End With
End Sub

複製代碼

s1 = Worksheets("甲").Cells(1, 1).End(xlDown).Row
s2 = Worksheets("乙").Cells(1, 1).End(xlDown).Row
s3 = Worksheets("統計").Cells(1, 1).End(xlDown).Row
s3_1 = Worksheets("統計").Cells(10000, 8).End(xlUp).Row
s3_2 = Worksheets("統計").Cells(10000, 9).End(xlUp).Row

w = MsgBox("請問要從統計第一天起開始更新", vbYesNoCancel, "!!")

If w = vbYes Then
      xx = 2
ElseIf w = vbNo Then
      xx = Application.Max(s3_1, s3_2)
ElseIf w = vbCancel Then
      b = MsgBox("取消更新!", vbOKOnly, "!!")
      Exit Sub
End If

For x3 = xx To s3
      up = Worksheets("統計").Cells(x3, 1)

      For x1 = 2 To s1
         If up = Worksheets("甲").Cells(x1, 1) Then
            q1 = x1
         End If
      Next x1

      For x2 = 2 To s2
         If up = Worksheets("乙").Cells(x2, 1) Then
            q2 = x2
         End If
      Next x2

      Worksheets("統計").Cells(x3, 2) = Worksheets("甲").Cells(q1, 12)
      Worksheets("統計").Cells(x3, 3) = Worksheets("乙").Cells(q2, 12)
Next x3

b = MsgBox("資料擷取完成!", vbOKOnly, "!!")

End Sub

Sub 擷取()
'分別宣告變數為Range(儲存格)物件，Rng為"統計"工作表的A欄每次循環中所讀取的儲存格，
'aRng為"甲"工作表查尋後找到的儲存格，bRng為"乙"工作表查尋後找到的儲存格
'Range到底是什麼？請查看說明
Dim Rng As Range, aRng As Range, bRng As Range
With Sheets("統計") 'with 為簡化代碼用，以下的代碼中若有以"."為開始的代碼，其前面都會加上"Sheets("統計")"這串
'例如".Cells"，其完整字句應該是 "Sheets("統計").Cells(...."
.Range("B2:C" & .Cells(Rows.Count, 1).End(xlUp).Row).ClearContents '清除內容(值)
'以從A2開始到最後一個位置為範圍(這裡查到的是A11)，做迴圈讀到的儲存格為Rng，例如第一個讀的位址為A2，其值(Value)為"2月25日"
'然後以其值"2月25日"去做搜尋(.Find)"甲"工作表和"乙"工作表，並找到其儲存格，搜尋日期在這裡不能用值去找，這裡必須要用公式去找"LookIn:=xlFormulas"
'這裡的參數如何使用，請參考Visual Basic 的說明"Range.Find"
For Each Rng In .Range("A2:A" & .Cells(Rows.Count, 1).End(xlUp).Row)
Set aRng = Sheets("甲").Columns(1).Find(Rng.Value, LookIn:=xlFormulas, LookAt:=xlWhole, SearchDirection:=2) '搜尋(.Find)"甲"工作表，並設定為aRng物件
Set bRng = Sheets("乙").Columns(1).Find(Rng.Value, LookIn:=xlFormulas, LookAt:=xlWhole, SearchDirection:=2) '搜尋(.Find)"乙"工作表，並設定為bRng物件
'若沒有查獲到 Rng 物件，則aRng或bRng會為Nothing，所以下面語句的解釋為如果aRng不是Nothing的話，
'以第一次循環的值為例，會在Rng.Offset(, 1)放入aRng.Offset(, 11)的值，也就是會在統計的B2放進甲的K2值，bRng亦同，會在C2放進乙的K2值，呼~~~
If Not aRng Is Nothing Then Rng.Offset(, 1) = aRng.Offset(, 11) '
If Not bRng Is Nothing Then Rng.Offset(, 2) = bRng.Offset(, 11)
Next
End With
End Sub

複製代碼

Option Explicit
Sub 擷取()
Dim Rng As Range, aRng As Range, bRng As Range
With Sheets("統計")
.Range("B2:C" & .Cells(Rows.Count, 1).End(xlUp).Row).ClearContents
For Each Rng In .Range("A2:A" & .Cells(Rows.Count, 1).End(xlUp).Row)
Set aRng = Sheets("甲").Columns(1).Find(Rng.Value, LookIn:=xlFormulas, LookAt:=xlWhole, SearchDirection:=2)
Set bRng = Sheets("乙").Columns(1).Find(Rng.Value, LookIn:=xlFormulas, LookAt:=xlWhole, SearchDirection:=2)
If Not aRng Is Nothing Then Rng.Offset(, 1) = aRng.Offset(, 11)
If Not bRng Is Nothing Then Rng.Offset(, 2) = bRng.Offset(, 11)
Rng.Offset(, 6) = -(Rng.Offset(, 1) + Rng.Offset(, 1))
Next
End With
End Sub

複製代碼