Board logo

標題: [發問] 如何把資料轉寫到對應的工作表 [打印本頁]
作者: man65boy    時間: 2017-10-15 21:23     標題: 如何把資料轉寫到對應的工作表

請教各位老師們，要如何把I欄分類中的資料A~J欄整列的資料轉寫到對應的工作表中，懇求老師們的幫忙。
附檔:[attach]27809[/attach]
作者: Hsieh    時間: 2017-10-16 09:38

回復 1# man65boy
  1. Private Sub CommandButton1_Click()
  2. Dim ar()
  3. Set d = CreateObject("Scripting.Dictionary")
  4. Set d1 = CreateObject("Scripting.Dictionary")

  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    時間: 2017-10-16 11:51

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

    謝謝老師的幫忙^^
作者: Hsieh    時間: 2017-10-16 18:00

回復 3# man65boy
  1. Private Sub CommandButton1_Click()
  2. Dim ar()
  3. Set d = CreateObject("Scripting.Dictionary")
  4. Set d1 = CreateObject("Scripting.Dictionary")

  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    時間: 2017-10-16 18:46

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

回復 4# Hsieh
小弟之前有發問過一個問題，就是在這工作表上的功能性在沿升，多了把選擇的類別，轉到指定的工作表上依序排列，附上之前發問的檔案參考:[attach]27811[/attach]
作者: Hsieh    時間: 2017-10-17 11:22

回復 6# man65boy
  1. Private Sub CommandButton1_Click()
  2. Dim ar()
  3. Set d = CreateObject("Scripting.Dictionary")
  4. Set d1 = CreateObject("Scripting.Dictionary")

  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    時間: 2017-10-17 14:08

回復 7# Hsieh

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



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