返回列表 上一主題 發帖

請問sheet 欄位轉換問題

Hsieh

帖子
4901 
主題
44 
精華
24 
積分
4916 
點名
120  
作業系統
Windows 7 
軟體版本
Office 20xx 
閱讀權限
150 
性別
男 
來自
台北 
註冊時間
2010-4-30 
最後登錄
2025-5-18 

2024年全勤獎章2023年全勤獎章2022虎年全勤獎章2021牛年全勤獎章2020鼠年全勤獎章2019 豬年全勤獎章2018 狗年全勤獎章2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱心公益勳章2011兔年全勤獎章
1# 跳轉到 »
發表於 2011-12-20 19:15 | 顯示全部帖子
回復 1# tonycho33
  1. Sub 轉置()
  2. Dim A As Range, Ar(), Ay(), i%, j%, Ary(), s&
  3. With Sheets("a")
  4. For Each A In .Range("A2", .Cells(.Rows.Count, 1).End(xlUp)).SpecialCells(xlCellTypeConstants)
  5. Ar = A.Resize(, 4)
  6. Ay = .Range(A.Offset(, 6), A.Offset(, 6).End(xlToRight).Offset(2)).Value
  7. For i = 1 To UBound(Ay, 2)
  8. ReDim Preserve Ary(7, s)
  9. Ary(0, s) = Ar(1, 1): Ary(1, s) = Ar(1, 2): Ary(6, s) = Ar(1, 4)
  10.    For j = 1 To UBound(Ay, 1)
  11.    Ary(j + 1, s) = Ay(j, i)
  12.    Next
  13.    s = s + 1
  14. Next
  15. Next
  16. End With
  17. Sheets("b").UsedRange.Offset(1) = ""
  18. Sheets("b").[A2].Resize(s, 7) = Application.Transpose(Ary)
  19. End Sub
複製代碼
sheet 欄位轉換.rar (11.01 KB)
學海無涯_不恥下問

TOP

Hsieh

帖子
4901 
主題
44 
精華
24 
積分
4916 
點名
120  
作業系統
Windows 7 
軟體版本
Office 20xx 
閱讀權限
150 
性別
男 
來自
台北 
註冊時間
2010-4-30 
最後登錄
2025-5-18 

2024年全勤獎章2023年全勤獎章2022虎年全勤獎章2021牛年全勤獎章2020鼠年全勤獎章2019 豬年全勤獎章2018 狗年全勤獎章2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱心公益勳章2011兔年全勤獎章
2#
發表於 2011-12-21 18:04 | 顯示全部帖子
回復 9# tonycho33


    sheet 欄位轉換.rar (13.16 KB)
學海無涯_不恥下問

TOP

Hsieh

帖子
4901 
主題
44 
精華
24 
積分
4916 
點名
120  
作業系統
Windows 7 
軟體版本
Office 20xx 
閱讀權限
150 
性別
男 
來自
台北 
註冊時間
2010-4-30 
最後登錄
2025-5-18 

2024年全勤獎章2023年全勤獎章2022虎年全勤獎章2021牛年全勤獎章2020鼠年全勤獎章2019 豬年全勤獎章2018 狗年全勤獎章2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱心公益勳章2011兔年全勤獎章
3#
發表於 2011-12-21 22:51 | 顯示全部帖子
回復 11# tonycho33
  1. Sub 轉置()
  2. Dim A As Range, Ar(), Ay(), i%, j%, Ary(), s&
  3. With Sheets("a")
  4. For Each A In .Range("A2", .Cells(.Rows.Count, 1).End(xlUp)).SpecialCells(xlCellTypeConstants) '在A2以下有資料的儲存格做迴圈
  5. Ar = A.Resize(, 4) 'A欄向右擴展成欄的範圍，取得工單、料號、摘要、數量
  6. Ay = .Range(A.Offset(, 6), A.Offset(, 6).End(xlToRight).Offset(2)).Value '從G欄向右到該列資料尾向下2列的範圍存入陣列變數
  7. For i = 1 To UBound(Ay, 2) '迴圈從1開始到資料陣列的欄數
  8. ReDim Preserve Ary(7, s) '，擴展動態陣列此陣列有7列，擴展成s欄
  9. Ary(0, s) = Ar(1, 1): Ary(1, s) = Ar(1, 2): Ary(6, s) = Ar(1, 4) '將工單、料號、數量寫入陣列
  10.    For j = 1 To UBound(Ay, 1)
  11.    Ary(j + 1, s) = Ay(j, i) '將每個工程的3個項目寫入陣列
  12.    Next
  13.    s = s + 1 '準備下次動態陣列擴增的欄數
  14. Next
  15. Next
  16. End With
  17. Sheets("b").UsedRange.Offset(1) = "" '清空原來資料
  18. Sheets("b").[A2].Resize(s, 7) = Application.Transpose(Ary) '將陣列寫入b工作表
  19. End Sub
複製代碼
學海無涯_不恥下問

TOP

Hsieh

帖子
4901 
主題
44 
精華
24 
積分
4916 
點名
120  
作業系統
Windows 7 
軟體版本
Office 20xx 
閱讀權限
150 
性別
男 
來自
台北 
註冊時間
2010-4-30 
最後登錄
2025-5-18 

2024年全勤獎章2023年全勤獎章2022虎年全勤獎章2021牛年全勤獎章2020鼠年全勤獎章2019 豬年全勤獎章2018 狗年全勤獎章2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱心公益勳章2011兔年全勤獎章
4#
發表於 2011-12-21 22:56 | 顯示全部帖子
回復 13# tonycho33

你的項目重複，請說明比對規則
學海無涯_不恥下問

TOP

Hsieh

帖子
4901 
主題
44 
精華
24 
積分
4916 
點名
120  
作業系統
Windows 7 
軟體版本
Office 20xx 
閱讀權限
150 
性別
男 
來自
台北 
註冊時間
2010-4-30 
最後登錄
2025-5-18 

2024年全勤獎章2023年全勤獎章2022虎年全勤獎章2021牛年全勤獎章2020鼠年全勤獎章2019 豬年全勤獎章2018 狗年全勤獎章2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱心公益勳章2011兔年全勤獎章
5#
發表於 2011-12-22 00:33 | 顯示全部帖子
回復 16# tonycho33

表格的合併儲存格問題
  1. Sub 轉置()
  2. Dim A As Range, Ar(), Ay(), i%, j%, Ary(), s&
  3. r = 2
  4. With Sheets("a")
  5. Do Until .Cells(r, 1) = ""
  6. Set A = .Cells(r, 1)
  7. Ar = A.Resize(, 4)
  8. k = Application.CountA(.Range(A.Offset(, 6), A.Offset(, 6).End(xlToRight)))
  9. Ay = A.Offset(, 6).Resize(3, k).Value
  10. For i = 1 To UBound(Ay, 2)
  11. ReDim Preserve Ary(7, s)
  12. Ary(0, s) = Ar(1, 1): Ary(1, s) = Ar(1, 2): Ary(6, s) = Ar(1, 4)
  13.    For j = 1 To UBound(Ay, 1)
  14.    Ary(j + 1, s) = Ay(j, i)
  15.    Next
  16.    s = s + 1
  17. Next
  18. r = r + 3
  19. Loop
  20. End With
  21. Sheets("b").UsedRange.Offset(1) = ""
  22. Sheets("b").[A2].Resize(s, 7) = Application.Transpose(Ary)
  23. End Sub

  25. Private Sub Worksheet_Activate()
  26. Set d = CreateObject("Scripting.Dictionary")
  27. With Sheet6
  28. For Each A In .Range("J:J").SpecialCells(xlCellTypeConstants)
  29.    If A = "ok" Then
  30.    mystr = Join(Application.Transpose(Application.Transpose(A.Offset(, -9).Resize(, 5).Value)), "")
  31.    d(mystr) = d.Count
  32.    End If
  33. Next
  34. End With
  35. With Me
  36. r = 2
  37. Do Until .Cells(r, 1) = ""
  38. Set A = .Cells(r, 1)
  39. mystr = A & A.Offset(, 1)
  40.    For Each c In .Range(A.Offset(, 6), A.Offset(, 6).End(xlToRight))
  41.       temp = mystr & Join(Application.Transpose(c.Resize(3, 1)), "")
  42.       If d.exists(temp) = True Then c.Resize(3, 1).Interior.ColorIndex = 38 Else c.Resize(3, 1).Interior.ColorIndex = 0
  43.    Next
  44. r = r + 3
  45. Loop
  46. End With
  47. End Sub
複製代碼
學海無涯_不恥下問

TOP

Hsieh

帖子
4901 
主題
44 
精華
24 
積分
4916 
點名
120  
作業系統
Windows 7 
軟體版本
Office 20xx 
閱讀權限
150 
性別
男 
來自
台北 
註冊時間
2010-4-30 
最後登錄
2025-5-18 

2024年全勤獎章2023年全勤獎章2022虎年全勤獎章2021牛年全勤獎章2020鼠年全勤獎章2019 豬年全勤獎章2018 狗年全勤獎章2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱心公益勳章2011兔年全勤獎章
6#
發表於 2012-1-19 14:19 | 顯示全部帖子
回復 28# tonycho33
  1. Sub 轉置()

  3. Dim A As Range, Ar(), Ay(), i%, j%, Ary(), s&

  5. r = 2

  7. With Sheets("a")

  9. Do Until .Cells(r, 1) = ""

  11. Set A = .Cells(r, 1)

  13. Ar = A.Resize(, 4)

  15. k = Application.CountA(.Range(A.Offset(, 6), A.Offset(, 6).End(xlToRight)))
  16. If k = 0 Then GoTo 10
  17. Ay = A.Offset(, 6).Resize(3, k).Value

  19. For i = 1 To UBound(Ay, 2)

  21. ReDim Preserve Ary(7, s)

  23. Ary(0, s) = Ar(1, 1): Ary(1, s) = Ar(1, 2): Ary(6, s) = Ar(1, 4)

  25.    For j = 1 To UBound(Ay, 1)

  27.    Ary(j + 1, s) = Ay(j, i)

  29.    Next

  31.    s = s + 1

  33. Next
  34. 10
  35. r = r + 3

  37. Loop

  39. End With

  41. Sheets("b").UsedRange.Offset(1) = ""

  43. Sheets("b").[A2].Resize(s, 7) = Application.Transpose(Ary)

  45. End Sub
複製代碼
學海無涯_不恥下問

TOP

Hsieh

帖子
4901 
主題
44 
精華
24 
積分
4916 
點名
120  
作業系統
Windows 7 
軟體版本
Office 20xx 
閱讀權限
150 
性別
男 
來自
台北 
註冊時間
2010-4-30 
最後登錄
2025-5-18 

2024年全勤獎章2023年全勤獎章2022虎年全勤獎章2021牛年全勤獎章2020鼠年全勤獎章2019 豬年全勤獎章2018 狗年全勤獎章2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱心公益勳章2011兔年全勤獎章
7#
發表於 2012-2-7 18:27 | 顯示全部帖子
回復 31# tonycho33

試試看
  1. Private Sub Worksheet_Activate()
  2. Set d = CreateObject("Scripting.Dictionary")
  3. Set d1 = CreateObject("Scripting.Dictionary")
  4. With Sheet6
  5. For Each A In .Range("I2", .[I65536].End(xlUp)).SpecialCells(xlCellTypeConstants)
  6.    If A <> "" And A.Offset(, 1) = "" Then
  7.    mystr = Join(Application.Transpose(Application.Transpose(A.Offset(, -8).Resize(, 5).Value)), "")
  8.    d(mystr) = d(mystr) + 1
  9.    ElseIf A.Offset(, 1) - A Then
  10.    mystr = Join(Application.Transpose(Application.Transpose(A.Offset(, -8).Resize(, 5).Value)), "")
  11.    d1(mystr) = d1(mystr) + 1
  12.    End If
  13. Next
  14. End With
  15. With Me
  16. r = 2
  17. Do Until .Cells(r, 1) = ""
  18. Set A = .Cells(r, 1)
  19. mystr = A & A.Offset(, 1)
  20.    For Each c In .Range(A.Offset(, 6), A.Offset(, 6).End(xlToRight))
  21.       temp = mystr & Join(Application.Transpose(c.Resize(3, 1)), "")
  22.       If d.exists(temp) = True Then
  23.       c.Resize(3, 1).Interior.ColorIndex = 4
  24.       ElseIf d1.exists(temp) = True Then
  25.       c.Resize(3, 1).Interior.ColorIndex = 6
  26.       Else
  27.       c.Resize(3, 1).Interior.ColorIndex = 0
  28.       End If
  29.    Next
  30. r = r + 3
  31. Loop
  32. End With
  33. End Sub
複製代碼
學海無涯_不恥下問

TOP

        靜思自在 : 做好事不能少我一人，做壞事不能多我一人。
返回列表 上一主題