[發問] 如何把資料轉寫到對應的工作表

man65boy

請教各位老師們，要如何把I欄分類中的資料A~J欄整列的資料轉寫到對應的工作表中，懇求老師們的幫忙。
附檔: 20171015.rar (7.23 KB)

下載次數: 12

2017-10-15 21:22

Hsieh

回復 1# man65boy

1. Private Sub CommandButton1_Click()
   
2. Dim ar()
   
3. Set d = CreateObject("Scripting.Dictionary")
   
4. Set d1 = CreateObject("Scripting.Dictionary")
   
5. 
   
6. For Each sh In Sheets
   
7.   d1(sh.Name) = ""
   
8. Next
   
9. For Each a In Range(Range("I2"), Range("I65536").End(xlUp))
   
10. If d1.exists(a.Value) Then
    
11. If IsEmpty(d(a.Value)) Then
    
12.    ReDim ar(0)
    
13.    ar(0) = a.Offset(, -8).Resize(, 10).Value
    
14.    d(a.Value) = ar
    
15.    Else
    
16.      ar = d(a.Value)
    
17.      i = UBound(ar) + 1
    
18.      ReDim Preserve ar(i)
    
19.      ar(i) = a.Offset(, -8).Resize(, 10).Value
    
20.      d(a.Value) = ar
    
21. End If
    
22. End If
    
23. Next
    
24. For Each ky In d.keys
    
25. k = UBound(d(ky)) + 1
    
26.   Sheets(ky).[A2].Resize(k, 10) = Application.Transpose(Application.Transpose(d(ky)))
    
27. Next
    
28. End Sub

複製代碼

man65boy

回復 2# Hsieh
謝謝Hsieh的回覆，小弟發問不夠明確，拍事，所以還要再修改，(依類別選後，在轉寫到對應的工作表後，不留轉寫後的資料在當前的工作表上。
PS:資料轉寫後，再依序排列，不留空白處。)詳細需求在每個工作表上有敘述，附檔 工作紀錄2.rar (18.68 KB)

下載次數: 14

2017-10-16 11:50

    謝謝老師的幫忙^^

Hsieh

回復 3# man65boy

1. Private Sub CommandButton1_Click()
   
2. Dim ar()
   
3. Set d = CreateObject("Scripting.Dictionary")
   
4. Set d1 = CreateObject("Scripting.Dictionary")
   
5. 
   
6. For Each sh In Sheets
   
7.   d1(sh.Name) = ""
   
8. Next
   
9. r = Range("I65536").End(xlUp).Row '資料尾
   
10. For j = r To 2 Step -1
    
11. Set a = Cells(j, "I")
    
12. If d1.exists(a.Value) Then
    
13. If IsEmpty(d(a.Value)) Then
    
14.    ReDim ar(0)
    
15.    ar(0) = a.Offset(, -8).Resize(, 10).Value
    
16.    d(a.Value) = ar
    
17.    Else
    
18.      ar = d(a.Value)
    
19.      i = UBound(ar) + 1
    
20.      ReDim Preserve ar(i)
    
21.      ar(i) = a.Offset(, -8).Resize(, 10).Value
    
22.      d(a.Value) = ar
    
23. End If
    
24. Rows(j).Delete '刪除資料列
    
25. End If
    
26. Next
    
27. For Each ky In d.keys
    
28. k = UBound(d(ky)) + 1
    
29.   Sheets(ky).[A2].Resize(k, 10) = Application.Transpose(Application.Transpose(d(ky)))
    
30. Next
    
31. End Sub

複製代碼

man65boy

回復 4# Hsieh
謝謝老師的回答，在總表的問題轉寫沒問題，但是在把總表的資料轉出到其他工作表時，會出現覆蓋，沒依序往下排列，簡單來說，總表轉寫出去後，會在不定時的作業，再轉寫出去，所以資料到其他工作表上，不能有覆蓋的動作，只能依排列方式往下，再麻煩老師了^^

man65boy

回復 4# Hsieh
小弟之前有發問過一個問題，就是在這工作表上的功能性在沿升，多了把選擇的類別，轉到指定的工作表上依序排列，附上之前發問的檔案參考: 以特定字元整列資料轉寫.rar (9.09 KB)

下載次數: 15

2017-10-17 10:50

Hsieh

回復 6# man65boy

1. Private Sub CommandButton1_Click()
   
2. Dim ar()
   
3. Set d = CreateObject("Scripting.Dictionary")
   
4. Set d1 = CreateObject("Scripting.Dictionary")
   
5. 
   
6. For Each sh In Sheets
   
7.   d1(sh.Name) = ""
   
8. Next
   
9. r = Range("I65536").End(xlUp).Row '資料尾
   
10. For j = r To 2 Step -1
    
11. Set a = Cells(j, "I")
    
12. If d1.exists(a.Value) Then
    
13. If IsEmpty(d(a.Value)) Then
    
14.    ReDim ar(0)
    
15.    ar(0) = a.Offset(, -8).Resize(, 10).Value
    
16.    d(a.Value) = ar
    
17.    Else
    
18.      ar = d(a.Value)
    
19.      i = UBound(ar) + 1
    
20.      ReDim Preserve ar(i)
    
21.      ar(i) = a.Offset(, -8).Resize(, 10).Value
    
22.      d(a.Value) = ar
    
23. End If
    
24. Rows(j).Delete '刪除資料列
    
25. End If
    
26. Next
    
27. For Each ky In d.keys
    
28. For i = UBound(d(ky)) To 0 Step -1
    
29.   Sheets(ky).[A65536].End(xlUp).Offset(1, 0).Resize(1, 10) = d(ky)(i)
    
30. Next
    
31. Next
    
32. End Sub

複製代碼

man65boy

回復 7# Hsieh

謝謝Hsieh 老師的幫忙解答，感激不盡!^^