Board logo

標題: [發問] 想請教兩筆不同資料如何整合成一筆?(以解決) [打印本頁]
作者: ivan731129    時間: 2011-2-18 09:45     標題: 想請教兩筆不同資料如何整合成一筆?(以解決)

本帖最後由 ivan731129 於 2011-2-22 10:52 編輯

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

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

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


因為怕小檔案太簡略，所以附上主要的格式標題參考之[attach]4772[/attach]
作者: Hsieh    時間: 2011-2-18 10:36

回復 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    時間: 2011-2-18 10:51

本帖最後由 ivan731129 於 2011-2-18 11:00 編輯

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

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

那因為我之後要修改到比較龐大資料上，想在拜託前輩們增加要是我要修改時要注意插入的注解。感謝前輩們!
作者: Hsieh    時間: 2011-2-18 14:04

回復 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    時間: 2011-2-18 16:05

再次感謝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    時間: 2011-2-19 12:21

回復 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    時間: 2011-2-22 10:09

本帖最後由 ivan731129 於 2011-2-22 10:32 編輯

上禮拜感謝前輩回應，但是後來在修改時
不知道是資料量問題還是設定錯誤，再跑時會出現型態不符合。請問是哪裡設錯?
  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    時間: 2011-2-22 10:52

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



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