[發問] 想請教兩筆不同資料如何整合成一筆?(以解決)

ivan731129

目前小弟在整合資料，想詢問關於整合不同類型檔案的問題。
以下是測試時寫的但是好像有很大問題，想請各位前輩們幫忙。

Sub 合併()
Dim dHead As Range, dDataCunt As Long, i As Long, dText As String
Set dHead = Range("合併對象")

dDataCunt = dHead.Cells(65536, 1).End(xlUp).Row - dHead.Row
For i = dDataCunt To 1 Step -1

    If dHead.Cells(i + 1, 1).Value = dHead.Cells(i, 1).Value And _
       dHead.Cells(i + 1, 2).Value = dHead.Cells(i, 2).Value Then

       dHead.Cells(i, 3).Value = dHead.Cells(i, 3).Value & "．" & dHead.Cells(i + 1, 3).Value
       dHead.Cells(i + 1, 3).EntireRow.Delete

    End If
Next i
dHead.Select: Beep
End Sub

test date.rar (8.01 KB)

附黨
下載次數: 16

2011-2-18 09:46

那資料部分如附檔(原檔資料因為蠻龐大所以刻意弄一個小資料去測試。)
主要是公司產量資料和公司地址，那地址資料是地區公司地址這樣，所以要把產量資料後面直接加上公司的相關地址資料這樣
那產量的公司比較少，所以地址資料要是所對應的產量資料沒有就不會增加筆數。
就原本是
a.公司 編號 產量 b.公司 地址 電話
整合成 >>公司 編號 產量 地址 電話
那條件是以下：
1.公司資料同ㄧ家只取同一天產量最大ㄧ筆，所以整合後會出現同家公司有兩天產量同編號這樣。
2.那編號原本有限定只取哪幾筆，那原本是想說先用巨集整合出一筆資料後再去篩選，
那要是可以在整合時就選定要取哪幾項就拜託各位前輩幫忙。


因為怕小檔案太簡略，所以附上主要的格式標題參考之 主要項目.rar (4.72 KB)

下載次數: 14

2011-2-18 11:22

Hsieh

回復 1# ivan731129

1. Sub Ex()
   
2. Dim A As Range
   
3. Set d = CreateObject("Scripting.Dictionary")
   
4. d("公司") = Array("公司", "編號", "產量", "地址", "電話")
   
5. With Sheet2
   
6.    For Each A In .Range(.[A2], .Cells(.Rows.Count, 1).End(xlUp))
   
7.      d(A.Value) = Array(A.Value, "", 0, A.Offset(, 1).Value, A.Offset(, 2).Value)
   
8.    Next
   
9. End With
   
10. With Sheet1
    
11.    For Each A In .Range(.[A2], .Cells(.Rows.Count, 1).End(xlUp))
    
12.    ar = d(A.Value)
    
13.      temp = ar(2): ar(1) = A.Offset(, 1).Value
    
14.      If A.Offset(, 2) > temp Then ar(2) = A.Offset(, 2)
    
15.      d(A.Value) = ar
    
16.    Next
    
17. End With
    
18. Sheet5.[A1].Resize(d.Count, 5) = Application.Transpose(Application.Transpose(d.items))
    
19. End Sub

複製代碼

ivan731129

先感謝Hsieh大回應，但這邊解出的結果似乎會變成以地址為主?因為看輸出結果變成沒有產量資料的公司也一起增加了。能夠只增加有產量並且有有地址的集合嗎?

因為結果變成單家公司只產出ㄧ筆產量資料。那我上面有修改成要是我同一家公司會有多天同產品編號我要產出多天產量同一編號時要如何去更改呢?

那因為我之後要修改到比較龐大資料上，想在拜託前輩們增加要是我要修改時要注意插入的注解。感謝前輩們!

Hsieh

回復 3# ivan731129

1. Sub Ex()
   
2. Dim A As Range
   
3. Set d = CreateObject("Scripting.Dictionary")
   
4. Set d1 = CreateObject("Scripting.Dictionary")
   
5. d1("公司") = Array("公司", "編號", "產量", "地址", "電話") '合併後標題列文字
   
6. With Sheet2
   
7.    For Each A In .Range(.[A2], .Cells(.Rows.Count, 1).End(xlUp))
   
8.      d(A.Value) = Array(A.Offset(, 1).Value, A.Offset(, 2).Value) '將客戶資料儲存
   
9.    Next
   
10. End With
    
11. With Sheet1
    
12.    For Each A In .Range(.[A2], .Cells(.Rows.Count, 1).End(xlUp))
    
13.    If IsEmpty(d1(A & A.Offset(, 3))) Then '以時間與客戶名稱為索引儲存
    
14.       d1(A & A.Offset(, 3)) = Array(A.Value, A.Offset(, 1).Value, A.Offset(, 3).Value, d(A.Value)(0), d(A.Value)(1))
    
15.      Else
    
16.      ar = d1(A & A.Offset(, 3))
    
17.      If A.Offset(, 3).Value > ar(2) Then ar(2) = A.Offset(, 3).Value
    
18.      d1(A & A.Offset(, 3)) = ar
    
19.     End If
    
20.    Next
    
21. End With
    
22. Sheet5.[A1].Resize(d1.Count, 5) = Application.Transpose(Application.Transpose(d1.items))
    
23. End Sub

複製代碼

ivan731129

再次感謝Hsieh前輩，但是我有問題對於裡面宣告的
d(A.Value) = Array(A.Offset(, 1).Value, A.Offset(, 2).Value)
d1(A & A.Offset(, 3)) = Array(A.Value, A.Offset(, 1).Value, A.Offset(, 3).Value, d(A.Value)(0), d(A.Value)(1))
這邊的值分別是對應兩塊資料的什麼項目?
另外當我要增加項目時我的矩陣大小和項目增加設定該在哪做變化?
感謝幫忙!

Hsieh

回復 5# ivan731129


d(A.Value) = Array(A.Offset(, 1).Value, A.Offset(, 2).Value)'這裡是公司資料以公司為索引對應的地址跟執行人
A.Offset(, 1).Value=地址
A.Offset(, 2).Value=執行人


d1(A & A.Offset(, 3)) = Array(A.Value, A.Offset(, 1).Value, A.Offset(, 3).Value, d(A.Value)(0), d(A.Value)(1)) '這是以公司名跟時間合併為索引對應的公司，編號，產量，地址，執行人
A.Value=公司
A.Offset(, 1).Value=編號
A.Offset(, 3).Value=產量
d(A.Value)(0)=地址
d(A.Value)(1)) =執行人

ivan731129

上禮拜感謝前輩回應，但是後來在修改時
不知道是資料量問題還是設定錯誤，再跑時會出現型態不符合。請問是哪裡設錯?

1. Sub Ex()
   
2. Sub Ex()
   
3. Dim A As Range
   
4. Set d = CreateObject("Scripting.Dictionary")
   
5. Set d1 = CreateObject("Scripting.Dictionary")
   
6. d1("機構管編") = Array("機構管編", "機構名稱", "申報時間", "申報重量", "最大月產生量", "平均月產生量", "事業機構地址", "負責人姓名", "負責人職稱", "負責人電話", "環保部門名稱", "環保部門負責人", "環保部門電話", "廢清書公告類別")
   
7. With Sheet2
   
8.    For Each A In .Range(.[A2], .Cells(.Rows.Count, 1).End(xlUp))
   
9.      d(A.Value) = Array(A.Offset(, 6).Value, A.Offset(, 12).Value, A.Offset(, 13).Value, A.Offset(, 14).Value, A.Offset(, 15).Value, A.Offset(, 16).Value, A.Offset(, 17).Value, A.Offset(, 31).Value)
   
10.    Next
    
11. End With
    
12. With Sheet1
    
13.    For Each A In .Range(.[A2], .Cells(.Rows.Count, 1).End(xlUp))
    
14.    If IsEmpty(d1(A & A.Offset(, 1))) Then
    
15.       d1(A & A.Offset(, 1)) = Array(A.Value, A.Offset(, 1).Value, A.Offset(, 8).Value, A.Offset(, 9).Value, A.Offset(, 10).Value, A.Offset(, 11).Value, d(A.Value)(0), d(A.Value)(1), , d(A.Value)(2), d(A.Value)(3), d(A.Value)(4), d(A.Value)(5), d(A.Value)(6), d(A.Value)(7))
    
16.      Else
    
17.      ar = d1(A & A.Offset(, 1))
    
18.      If A.Offset(, 10).Value > ar(10) Then ar(10) = A.Offset(, 10).Value
    
19.      d1(A & A.Offset(, 1)) = ar
    
20.     End If
    
21.    Next
    
22. End With
    
23. Sheet5.[A1].Resize(d1.Count, 19) = Application.Transpose(Application.Transpose(d1.items))
    
24. End Sub

複製代碼

ivan731129

阿  抱歉問題我自己找到了!
感謝各位!!