ªð¦^¦Cªí ¤W¤@¥DÃD µo©«

¦Û°ÊÂ^¨ú¸ê®Æ­pºâ«á²£¥Í·J¾ã«áªºÀÉ®×

¦Û°ÊÂ^¨ú¸ê®Æ­pºâ«á²£¥Í·J¾ã«áªºÀÉ®×

±z¦n
À£ÁYÀɮפ¤¦³3­ÓexcelÀÉ,
½Ð°Ý¦p¦ó¼gVBAµ{¦¡,¥i¥H§Q¥Î"¾P°â¸ê®Æ"¤Î"¥Ø¼Ð¸ê®Æ"ÀÉ®×
©ó¥´¶}"¦¨ªG"ªºÀÉ®×®É,«ö¤U"«ö¶s1",«h¥i¦Û°Ê±a¥X¶À¦âªº¸ê®Æ²Î­p?
ÁÂÁÂ




Excel.zip (22.92 KB)
Jessica

¥»©«³Ì«á¥Ñ Hsieh ©ó 2012-10-6 17:25 ½s¿è

¦^´_ 1# jessicamsu
¸Õ¸Õ¬Ý
  1. Sub ex()
  2. Application.DisplayAlerts = False
  3. Application.ScreenUpdating = False
  4. Dim Target As Workbook, Sale As Workbook, A As Range, m
  5. Set dn = CreateObject("Scripting.Dictionary")
  6. Set dm = CreateObject("Scripting.Dictionary")

  7. Set d = CreateObject("Scripting.Dictionary")
  8. Set d1 = CreateObject("Scripting.Dictionary")
  9. Set Dic2 = CreateObject("Scripting.Dictionary")
  10. 10
  11. m = InputBox("¿é¤J¤ë¥÷", , 8)
  12. If Val(m) < 1 Or Val(m) > 12 Then GoTo 10
  13. Set Sale = Workbooks.Open(ThisWorkbook.Path & "\¾P°â¸ê®Æ.xlsx")
  14. Set Target = Workbooks.Open(ThisWorkbook.Path & "\¥Ø¼Ð¸ê®Æ.xlsx")
  15. With Sale '¾P°â
  16.   With .Sheets(1)
  17.      For Each A In .Range(.[B2], .[B2].End(xlDown)).SpecialCells(xlCellTypeConstants)
  18.      dm(A.Offset(, 3).Value) = ""
  19.        mystr = A.Value & "," & A.Offset(, -1).Value
  20.        If A.Offset(, 3) = Val(m) Then
  21.        If d(mystr) = "" Then
  22.        d(mystr) = A.Offset(, 1)
  23.          Else
  24.        d(mystr) = IIf(InStr(d(mystr), A.Offset(, 1)) = 0, d(mystr) & "," & A.Offset(, 1), d(mystr))
  25.        End If
  26.        d1(mystr) = d1(mystr) + A.Offset(, 2)
  27.        End If
  28.        dn(mystr) = Array(A.Offset(, -1).Value, A.Value, UBound(Split(d(mystr), ",")) + 1, d1(mystr))
  29.      Next
  30.   End With
  31.   .Close 0
  32. End With
  33. With Target '¥Ø¼Ð
  34.   With .Sheets(1)
  35.      For Each A In .Range(.[B2], .[B2].End(xlDown)).SpecialCells(xlCellTypeConstants)
  36.      dm(A.Offset(, 3).Value) = ""
  37.      mystr = A.Value & "," & A.Offset(, -1).Value
  38.       dn(mystr) = Array(A.Offset(, -1).Value, A.Value, UBound(Split(d(mystr), ",")) + 1, d1(mystr))
  39.       Dic2(A.Offset(, -1) & A & "," & A.Offset(, 3)) = A.Offset(, 2)
  40.      Next
  41.   End With
  42.   .Close 0
  43. End With
  44. With ActiveSheet
  45. .UsedRange.EntireColumn.Delete
  46. .[A1:A2] = "Sales Name": .[B1:B2] = "Bill TO": .[C1:C2] = "«È¤á¼Æ" & Chr(10) & "(" & m & "¤ë)": .[D2] = "¾P°â¶q" & Chr(10) & "(" & m & "¤ë)"
  47. .[D1:E1] = "¾P°â¹êÁZ": .[F1].Resize(, dm.Count - 1) = "¥Ø¼Ð"
  48. With .[A3].Resize(dn.Count, 4)
  49. .Value = Application.Transpose(Application.Transpose(dn.items))
  50. .Sort key1:=.Cells(1, 2), key2:=.Cells(1, 1), Header:=xlNo
  51. k = 4
  52. For Each ky In dm.keys
  53. ActiveSheet.Cells(2, k + 1) = "(" & ky & "¤ë¥÷)"
  54.   For Each A In .Columns(1).Cells
  55.      mystr = A & A.Offset(, 1) & "," & ky
  56.      A.Offset(, k) = Dic2(mystr)
  57.   Next
  58.     k = k + 1
  59. Next
  60. End With
  61. With .Range("A2").CurrentRegion.Offset(1)
  62. .Subtotal GroupBy:=2, Function:=xlSum, TotalList:=Array(3, 4, 5, 6, _
  63.         7), Replace:=True, PageBreaks:=False, SummaryBelowData:=True
  64.         .Cells(1, 1).ClearOutline
  65. For r = .Rows.Count To 3 Step -1
  66.    Set A = .Cells(r, 2)
  67.    If A = A.Offset(-1, 0) Then Range(A, A.Offset(-1, 0)).Merge
  68. Next
  69. End With
  70. .[A1:A2].Merge
  71. .[B1:B2].Merge
  72. .[C1:C2].Merge
  73. .[D1:E1].Merge
  74. .[F1].Resize(, dm.Count - 1).Merge
  75. .UsedRange.SpecialCells(xlCellTypeFormulas).Font.Bold = True
  76. End With
  77. Application.DisplayAlerts = True
  78. Application.ScreenUpdating = True
  79. End Sub
½Æ»s¥N½X
¾Ç®üµL²P_¤£®¢¤U°Ý

TOP

¦^´_ 2# Hsieh

¤£¦n·N«ä,²Ä63~64¦æ¥X²{»yªk¿ù»~
thanks
Jessica

TOP

¦^´_ 3# jessicamsu

¤£ª¾¹D©p¬°¦ó·|¥X²{¿ù»~
§Ú¥H©p¤W¶Çªº½d¨ÒÀÉ°õ¦æ¬O¥¿½Tªº
    play.gif
¾Ç®üµL²P_¤£®¢¤U°Ý

TOP

        ÀR«ä¦Û¦b : ¯u¥¿ªº·R¤ß¡A¬O·ÓÅU¦n¦Û¤vªº³oÁû¤ß¡C
ªð¦^¦Cªí ¤W¤@¥DÃD