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

[µo°Ý] vbaªº¿z¿ï¥\¯à (¨ú®ø³¡¤À¿z¿ï)

¦^´_ 59# wei9133

¦pªG¥ª¥k¤£¥Î¤ñ¹ï ¨º´Nª½±µ¤ñ¹ï¬P¶H ¦A¶i¦æ³Ó³õ ¸ò ±Ñ³õ ¥[Á`¥i¥H¶Ü?

TOP

¦^´_ 59# wei9133

¦³ªÅÀ°§Ú¸Õ¸Õ¬Ý  ³o­ÓÀ³¸Ó¥i¥H  ¦ý¬O¦³¤@­Ó«Ü¤jªº°ÝÃD ...¦pªG¸ê®Æ«Ü¦h ·|¶]«D±`ºC....
  1. Public Sub ½m²ß1116()
  2. Sheets(2).Select
  3. Rows(2).Select
  4. ActiveWindow.FreezePanes = False
  5. Application.ScreenUpdating = False
  6. Sheets(2).[A1].CurrentRegion.Clear
  7. Sheets(1).Select
  8. Dim Arr, D, xD, x&, y&, k&, T1$, T2$, T3$, T4$
  9. Set xD = CreateObject("Scripting.Dictionary")
  10. Arr = Range(Cells(Rows.Count, 1).End(xlUp), Cells(1, 115))
  11. For x = 2 To UBound(Arr, 1)
  12.     T1 = ""
  13.     For y = 1 To 51
  14.         T1 = T1 & Arr(x, y)
  15.         If Arr(x, y) = "" Then T1 = T1 & "-"
  16.     Next y
  17.     T3 = ""
  18.     For y = 52 To 102
  19.         T3 = T3 & Arr(x, y)
  20.         If Arr(x, y) = "" Then T3 = T3 & "-"
  21.     Next y
  22.     T1 = T1 & T3 & Arr(x, 106)
  23.     T3 = ""
  24.     If Arr(x, 103) = "" Then
  25.         Arr(x, 103) = 1
  26.         xD(T1) = xD(T1) + Arr(x, 103)
  27.     ElseIf Arr(x, 103) <> "" Then
  28.         xD(T1) = xD(T1) + Arr(x, 103) + 1
  29.     End If
  30.     xD(T1 & 105) = xD(T1 & 105) + Arr(x, 105)
  31.     xD(Arr(x, 106)) = xD(Arr(x, 106)) + 1
  32. Next x
  33. T1 = "": k = 2
  34. For Each D In xD
  35.     For x = 2 To UBound(Arr, 1)
  36.         T2 = ""
  37.         For y = 1 To 51
  38.             T2 = T2 & Arr(x, y)
  39.             If Arr(x, y) = "" Then T2 = T2 & "-"
  40.         Next y
  41.         T4 = ""
  42.         For y = 52 To 102
  43.             T4 = T4 & Arr(x, y)
  44.             If Arr(x, y) = "" Then T4 = T4 & "-"
  45.         Next y
  46.         T2 = T2 & T4 & Arr(x, 106)
  47.         T4 = ""
  48.         If D = T2 Then
  49.             Arr(x, 103) = xD(D) - 1
  50.             Arr(x, 105) = xD(D & 105)
  51.             If Arr(x, 107) <> "" Or Arr(x, 109) <> "" _
  52.             Or Arr(x, 115) <> "" Or Arr(x, 104) <> "" Then
  53.                  For y = 1 To UBound(Arr, 2)
  54.                      Arr(k, y) = Arr(x, y)
  55.                  Next y
  56.             k = k + 1
  57.             Exit For
  58.             End If
  59.         End If
  60.         If D = Arr(x, 106) And xD(D) = 1 _
  61.         And Arr(x, 107) = "" And Arr(x, 109) = "" _
  62.         And Arr(x, 115) = "" And Arr(x, 104) = "" Then
  63.             For y = 1 To UBound(Arr, 2)
  64.                 Arr(k, y) = Arr(x, y)
  65.             Next y
  66.         k = k + 1
  67.         Exit For
  68.         End If
  69.     Next x
  70. If Arr(k - 1, 103) = 0 Then Arr(k - 1, 103) = ""
  71. If Arr(k - 1, 105) = 0 Then Arr(k - 1, 105) = ""
  72. Debug.Print k
  73. Debug.Print D
  74. Next D
  75. T2 = "": Set xD = Nothing
  76. Sheets(2).Range("A1").Resize(k - 1, UBound(Arr, 2)) = ""
  77. Sheets(2).Range("A1").Resize(k - 1, UBound(Arr, 2)) = Arr
  78. Erase Arr
  79. Application.ScreenUpdating = True
  80. Sheets(2).Select
  81. Rows(2).Select
  82. ActiveWindow.FreezePanes = True
  83. Cells(Rows.Count, 106).End(xlUp).Select
  84. End Sub
½Æ»s¥N½X

TOP

¦^´_ 59# wei9133

³o·|¤ñ¸û§Ö¤@ÂI ¦ý¬OÁÙ¬O«ÜºC... ¦³ªÅÀ°§Ú¸Õ¸Õ¬Ý¦³¨S¦³°ÝÃD   ·PÁÂ
  1. Public Sub ½m²ß1118()
  2. Sheets(2).Select
  3. Rows(2).Select
  4. ActiveWindow.FreezePanes = False
  5. Application.ScreenUpdating = False
  6. Sheets(2).[A1].CurrentRegion.Clear
  7. Sheets(1).Select
  8. Dim Arr, D, xD, x&, y&, k&, T1$, T3$, E()
  9. Set xD = CreateObject("Scripting.Dictionary")
  10. Arr = Range(Cells(Rows.Count, 1).End(xlUp), Cells(1, 115))
  11. For x = 2 To UBound(Arr, 1)
  12.     T1 = ""
  13.     For y = 1 To 51
  14.         T1 = T1 & Arr(x, y)
  15.         If Arr(x, y) = "" Then T1 = T1 & "|"
  16.     Next y
  17.     T3 = ""
  18.     For y = 52 To 102
  19.         T3 = T3 & Arr(x, y)
  20.         If Arr(x, y) = "" Then T3 = T3 & "|"
  21.     Next y
  22.     T1 = T1 & T3 & Arr(x, 106)
  23.     ReDim Preserve E(x)
  24.     E(x) = T1
  25.     T3 = ""
  26.     If Arr(x, 103) = "" Then
  27.         Arr(x, 103) = 1
  28.         xD(T1) = xD(T1) + Arr(x, 103)
  29.     ElseIf Arr(x, 103) <> "" Then
  30.         xD(T1) = xD(T1) + Arr(x, 103) + 1
  31.     End If
  32.     xD(T1 & 105) = xD(T1 & 105) + Arr(x, 105)
  33.     xD(Arr(x, 106)) = xD(Arr(x, 106)) + 1
  34. Next x
  35. T1 = "": k = 2
  36. For Each D In xD
  37.     For x = 2 To UBound(Arr, 1)
  38.         If D = E(x) Then
  39.             Arr(x, 103) = xD(D) - 1
  40.             Arr(x, 105) = xD(D & 105)
  41.             If Arr(x, 107) <> "" Or Arr(x, 109) <> "" _
  42.             Or Arr(x, 115) <> "" Or Arr(x, 104) <> "" Then
  43.                  For y = 1 To UBound(Arr, 2)
  44.                      Arr(k, y) = Arr(x, y)
  45.                  Next y
  46.             k = k + 1
  47.             Exit For
  48.             End If
  49.         End If
  50.         If D = E(x) And xD(D) = 1 _
  51.         And Arr(x, 107) = "" And Arr(x, 109) = "" _
  52.         And Arr(x, 115) = "" And Arr(x, 104) = "" Then
  53.             For y = 1 To UBound(Arr, 2)
  54.                 Arr(k, y) = Arr(x, y)
  55.             Next y
  56.         k = k + 1
  57.         Exit For
  58.         End If
  59.     Next x
  60. If Arr(k - 1, 103) = 0 Then Arr(k - 1, 103) = ""
  61. If Arr(k - 1, 105) = 0 Then Arr(k - 1, 105) = ""
  62. Next D
  63. Set xD = Nothing: Erase E
  64. Sheets(2).Range("A1").Resize(k - 1, UBound(Arr, 2)) = Arr
  65. Erase Arr
  66. Application.ScreenUpdating = True
  67. Sheets(2).Select
  68. Rows(2).Select
  69. ActiveWindow.FreezePanes = True
  70. Cells(Rows.Count, 106).End(xlUp).Select
  71. End Sub
½Æ»s¥N½X

TOP

¦^´_ 59# wei9133

­è¤~¸Õ¤F¤@¤Uµo²{ 106¬P¶H¦³°ÝÃD §ï¤F¤@¤U  ¡A¦³ªÅ¦AÀ°§Ú¸Õ¸Õ¬Ý ¦³¨S¦³°ÝÃD¡A·PÁÂ

javascript:;

¹ï¾Ô²Î­p -1120_.rar (652.91 KB)

TOP

        ÀR«ä¦Û¦b : ¯à·F¤£·F¡A¤£¦p­W·F¹ê·F¡C
ªð¦^¦Cªí ¤W¤@¥DÃD