- ©«¤l
- 254
- ¥DÃD
- 6
- ºëµØ
- 0
- ¿n¤À
- 310
- ÂI¦W
- 0
- §@·~¨t²Î
- W10
- ³nÅ骩¥»
- Excel 2016
- ¾\ŪÅv
- 20
- ©Ê§O
- ¨k
- ¨Ó¦Û
- ¥xÆW
- µù¥U®É¶¡
- 2019-6-16
- ³Ì«áµn¿ý
- 2024-9-23
|
¥»©«³Ì«á¥Ñ °a¤ªºµ ©ó 2020-10-25 10:49 ½s¿è
¦^´_ 34# wei9133
·Pı±Ñ§½ ©Ç©Çªº ©Ò¥H§ï¤F¤@¤U ¦³ªÅÀ°§Ú¬Ý¤@¤U ·PÁ ¶]ªº³t«×ºC¤F¤@¨Ç ¤£ª¾¦p¦ó¥[§Ö³t«×.....- Public Sub ½m²ß1025()
- Application.ScreenUpdating = False
- Sheets(1).Select
- Sheets(2).[a1].CurrentRegion.Clear
- Dim Arr, D, xD, xD1, x&, y&, k&, T1$, T2$, T3$, T4$
- Set xD = CreateObject("Scripting.Dictionary")
- Set xD1 = CreateObject("Scripting.Dictionary")
- Arr = Range(Cells(Rows.Count, 1).End(xlUp), Cells(1, 115))
- For x = 2 To UBound(Arr, 1)
- T1 = ""
- For y = 1 To 51
- T1 = T1 & Arr(x, y)
- If Arr(x, y) = "" Then T1 = T1 & "-"
- Next y
- T3 = ""
- For y = 52 To 102
- T3 = T3 & Arr(x, y)
- If Arr(x, y) = "" Then T3 = T3 & "-"
- Next y
- If T1 = T3 Then
- T1 = T1 & T3 & Arr(x, 106)
- T3 = ""
- If Arr(x, 103) = "" Then
- Arr(x, 103) = 1
- xD(T1) = xD(T1) + Arr(x, 103)
- ElseIf Arr(x, 103) <> "" Then
- xD(T1) = xD(T1) + Arr(x, 103)
- End If
- xD1(T1) = xD1(T1) + Arr(x, 105)
- End If
- Next x
- T1 = "": T3 = ""
- For Each D In xD
- For x = UBound(Arr, 1) To 2 Step -1
- T2 = ""
- For y = 1 To 51
- T2 = T2 & Arr(x, y)
- If Arr(x, y) = "" Then T2 = T2 & "-"
- Next y
- T4 = ""
- For y = 52 To 102
- T4 = T4 & Arr(x, y)
- If Arr(x, y) = "" Then T4 = T4 & "-"
- Next y
- If T2 = T4 Then
- T2 = T2 & T4 & Arr(x, 106)
- T4 = ""
- If D = T2 Then
- Arr(x, 103) = xD(D)
- Arr(x, 105) = xD1(D)
- End If
- End If
- Next x
- Next D
- T2 = "": T4 = "": D = "": k = 1
- For x = 2 To UBound(Arr, 1)
- If Arr(x, 103) <> "" Or Arr(x, 105) <> "" Then
- If Arr(x, 107) <> "" Or Arr(x, 109) <> "" _
- Or Arr(x, 115) <> "" Or Arr(x, 104) <> "" Then
- k = k + 1
- End If
- For y = 1 To UBound(Arr, 2)
- If Arr(x, 107) <> "" Or Arr(x, 109) <> "" _
- Or Arr(x, 115) <> "" Or Arr(x, 104) <> "" Then
- Arr(k, y) = Arr(x, y)
- End If
- Next y
- End If
- Next x
- Set xD = Nothing
- Set xD1 = Nothing
- Sheets(2).Range("A1").Resize(k, UBound(Arr, 2)) = ""
- Sheets(2).Range("A1").Resize(k, UBound(Arr, 2)) = Arr
- Erase Arr
- Sheets(2).Select
- Application.ScreenUpdating = True
- End Sub
½Æ»s¥N½X |
|