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

[µo°Ý] ½Ð±Ð¡A¦p¦ó½Æ»s¤£¦P¤u§@ªí¯S©wÄæ¦ì(©¿²¤ªÅ¥Õ­È)¨ì¤@­Ó¤u§@ªí¤W

¥»©«³Ì«á¥Ñ ­ã´£³¡ªL ©ó 2020-8-4 16:44 ½s¿è

¦^´_ 9# edmondsforum

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

TOP

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

TOP

¥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.     Dim A()
  4.     For I = 2 To Sheets.Count
  5.         ReDim Preserve A(I - 1)
  6.         A(I - 1) = Sheets(I).Cells(2, 2)
  7.     Next I
  8.    
  9.     G = Application.Max(A)

  10.     ActiveWorkbook.Save
  11.     For k = 1 To G
  12.         For I = 2 To Sheets.Count
  13.             Sheets(I).Select
  14.             If Format(Sheets(I).Cells(2, 2), "[DBNum1]0") = Format(k, "[DBNum1]0") Then
  15.                 If Sheets(1).Cells(6, 2) = "" Then
  16.                     Sheets(I).Range(Cells(1, 1).SpecialCells(xlCellTypeConstants), Sheets(I).Cells(1, 1).SpecialCells(xlCellTypeLastCell)).Copy Sheets(1).Cells(6, 2)
  17.                 ElseIf Sheets(1).Cells(6, 2) <> "" Then
  18.                     u = Sheets(1).Cells(1, 1).SpecialCells(xlCellTypeLastCell).Offset(2, 0).Address(0, 0)
  19.                     Sheets(I).Range(Cells(1, 1).SpecialCells(xlCellTypeConstants), Sheets(I).Cells(1, 1).SpecialCells(xlCellTypeLastCell)).Copy Sheets(1).Cells(Mid(u, 2), 2)
  20.                 End If
  21.             End If
  22.         Next I
  23.     Next k
  24.     Sheets(1).Select
  25.     Range(Cells(1, 1), Cells(1, 1).SpecialCells(xlCellTypeLastCell).Offset(0, 1).Address(0, 0)).Name = "Print_Area"
  26.    
  27.     Application.ScreenUpdating = True
  28. End Sub
½Æ»s¥N½X

TOP

¦^´_ 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¥Î®æ¦¡

TOP

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

³æ»ù¤ÀªR¤Àªí:
20231206_1.jpg
2023-12-6 10:32


³æ»ù¤ÀªRÁ`ªí°õ¦æµ²ªG:
20231206_2.jpg
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
¥Î¦æ°Ê¸Ë¸mÂsÄý½×¾Â¾Ç²ß«Ü¤è«K,ÁÂÁ½׾¸gÀç¹Î¶¤
½Ð¤j®a¤@°_¤W½×¾Â¨Ó¥æ¬y

TOP

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