­ã´£³¡ªL

¦^´_ 9# edmondsforum

½s¸¹­­©w 1 ~ 99
§ó¥¿ÀÉ:
Xl0000176.rar (23.88 KB)

¤U¸ü¦¸¼Æ: 5

2020-8-4 16:44

­ã´£³¡ªL

¥Î¦r¨å±a¤J½s¸¹:
Xl0000176-1.rar (23.13 KB)

¤U¸ü¦¸¼Æ: 9

2020-8-4 16:53

°a¤ªºµ

¥H¤U¬O¸ÕµÛ½m²ßªºµ²ªG µ{¦¡«ÜÃlªø ½Ð¤j¤j­Ì«üÂI¤@¤U¬Ý¬Ý¦³¨S¦³¦a¤è¤£¾A¦X³o¼Ëªº¼gªk
½Ð§iª¾¤p§Ì  ½Ð°Ý¦pªG­n³]©w¦C¦L¤À­¶ªº­¶¼Æ½d³ò ¸Ó¦p¦ó¼g©O? ½Ð¤j¤j­ÌÀ°À°¦£

1. Sub ´ú¸Õ½m²ß()
   
2.     Application.ScreenUpdating = False
   
3. 
   
4.     Dim A()
   
5.     For I = 2 To Sheets.Count
   
6.         ReDim Preserve A(I - 1)
   
7.         A(I - 1) = Sheets(I).Cells(2, 2)
   
8.     Next I
   
9.    
   
10.     G = Application.Max(A)
    
11. 
    
12.     ActiveWorkbook.Save
    
13.     For k = 1 To G
    
14.         For I = 2 To Sheets.Count
    
15.             Sheets(I).Select
    
16.             If Format(Sheets(I).Cells(2, 2), "[DBNum1]0") = Format(k, "[DBNum1]0") Then
    
17.                 If Sheets(1).Cells(6, 2) = "" Then
    
18.                     Sheets(I).Range(Cells(1, 1).SpecialCells(xlCellTypeConstants), Sheets(I).Cells(1, 1).SpecialCells(xlCellTypeLastCell)).Copy Sheets(1).Cells(6, 2)
    
19.                 ElseIf Sheets(1).Cells(6, 2) <> "" Then
    
20.                     u = Sheets(1).Cells(1, 1).SpecialCells(xlCellTypeLastCell).Offset(2, 0).Address(0, 0)
    
21.                     Sheets(I).Range(Cells(1, 1).SpecialCells(xlCellTypeConstants), Sheets(I).Cells(1, 1).SpecialCells(xlCellTypeLastCell)).Copy Sheets(1).Cells(Mid(u, 2), 2)
    
22.                 End If
    
23.             End If
    
24.         Next I
    
25.     Next k
    
26.     Sheets(1).Select
    
27.     Range(Cells(1, 1), Cells(1, 1).SpecialCells(xlCellTypeLastCell).Offset(0, 1).Address(0, 0)).Name = "Print_Area"
    
28.    
    
29.     Application.ScreenUpdating = True
    
30. End Sub

½Æ»s¥N½X

edmondsforum

¦^´_ 12# ­ã´£³¡ªL

ÁÂÁ­ã¤j¡A¤p§Ì¨ØªA±o¤­Åé§ë¦a°Ú¡I
³ø§i­ã¤j¡A¤p§Ì¦³µo²{§A®æ¦¡­ì¥»¬O¨Ï¥Î [DBNum1]0
¦]¬°§Ú·Q­n§e²{¤Q ¤Q¤@ ¤Q¤G ©Ò¥H§Ú§ï¦¨  [DBNum1][$-ja-JP]G/³q¥Î®æ¦¡

Andy2483

ÁÂÁ½׾Â,ÁÂÁ¦U¦ì«e½ú
«á¾ÇÂǦ¹©«¾Ç²ß¨ì«Ü¦hª¾ÃÑ,¥H1#½d¨Òªº¾Ç²ß¤è®×¦p¤U,½Ð¦U¦ì«e½ú«ü±Ð

³æ»ù¤ÀªR¤Àªí:

¤U¸ü (131.18 KB)

2023-12-6 10:32

³æ»ù¤ÀªRÁ`ªí°õ¦æµ²ªG:

¤U¸ü (120.75 KB)

2023-12-6 10:32

Option Explicit
Sub TEST()
Dim Z, Q, i&, R&, V&, c%, xR As Range, xA As Range, Sh As Worksheet
Set Z = CreateObject("Scripting.Dictionary")
Set Sh = ¤u§@ªí1: Range(Sh.[A1], Sh.UsedRange).Offset(5).Delete
Set xR = [³æ»ù¤ÀªRÁ`ªí!B6]
For i = 0 To 10: Z(Right(Application.Text(i, "[DBNum1]"), 1)) = i: Next
For i = 1 To Worksheets.Count
   If Right(Trim(Sheets(i).Name), 5) <> "-³æ»ù¤ÀªR" Then GoTo i01
   Q = Trim(Sheets(i).[B2]) & "¡³¡³¡³"
   For c = 1 To 3: V = Val(V & Z(Mid(Q, c, 1))): Next
   Set Z(V) = Sheets(i): V = 0
i01: Next
For i = 1 To Z.Count
   Q = Application.Small(Z.Keys, i)
   If IsError(Q) Then Exit For
   Set xA = Range(Z(Q).[B2], Z(Q).[G65536].End(3)(1, 2))
   xA.Copy xR
   Set xR = xR.Item(xA.Rows.Count + 2)
Next
With Sh.UsedRange: .Font.ColorIndex = 1: .Value = .Value: End With
Range(Sh.[A1], xR(-1, 8)).Name = "Print_Area"
End Sub