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

[µo°Ý] Excel¦X¨Ö¦C¦L

[µo°Ý] Excel¦X¨Ö¦C¦L

¥»©«³Ì«á¥Ñ max67424 ©ó 2023-6-14 03:52 ½s¿è




½Ð¯q½×¾Â¸Ì¦U¦ìVBA°ª¤â¡A¸Ó¦p¦ó¼¶¼gVBA¡A¤~¯à±N¤u§@ªíªº¤º®e°µ¨ì¹³wordªº¦X¨Ö¦C¦L¥\¯à¡AÁÂÁ¡C
«ÝÅç²M³æ¤Î¦¬®Æ¼ÐÅÒ.rar (77.61 KB)

¦^´_ 1# max67424


    ÁÂÁ½׾Â,ÁÂÁ«e½úµoªí¦¹¥DÃD»P½d¨Ò
«á¾ÇÂǦ¹©«½m²ßVBA°}¦C,¾Ç²ß¤è®×¦p¤U,½Ð«e½ú°Ñ¦Ò

¸ê®Æªí:


°õ¦æµ²ªG:



Option Explicit
Sub TEST()
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Dim Brr, A, B, Z, i&, j%, xR As Range
A = Array(1, 2, 5, 6, 11, 15, 16, 17, 19, 22, 27, 28, 31, 35, 40)
B = Array(2, 3, 4, 17, 5, 6, 7, 8, 9, 10, 11, 16, 12, 13, 14)
Brr = Range([¦¬®Æ¼ÐÅÒ!Q2], [¦¬®Æ¼ÐÅÒ!A65536].End(3))
Set xR = [¼ÐÅÒª©«¬!A1:E8]
On Error Resume Next: Sheets("¦X¨Ö¦C¦L").Delete: On Error GoTo 0
Sheets("¼ÐÅÒª©«¬").Copy after:=Worksheets(Sheets.Count)
With Sheets(Sheets.Count)
   .Name = "¦X¨Ö¦C¦L": .[A:E].Clear
   With .DrawingObjects
      If .Count > 0 Then .Delete
   End With
End With
For i = 1 To UBound(Brr)
   If Brr(i, 5) = "" Then Exit For
   For j = 0 To UBound(A): xR(A(j)) = Brr(i, B(j)): Next
   xR(1) = xR(1) & "-": xR(16) = "­Ü:" & xR(16) & "/"
   xR(17) = "Àx:" & xR(17) & "/": xR(28) = "(" & xR(28) & ")"
   xR(40) = xR(40) & Brr(i, UBound(A) + 1)
   xR.Copy Sheets("¦X¨Ö¦C¦L").Cells((i - 1) * 8 + 1, 1)
Next
Set xR = Nothing: Erase Brr, A, B
End Sub
¥Î¦æ°Ê¸Ë¸mÂsÄý½×¾Â¾Ç²ß«Ü¤è«K,ÁÂÁ½׾¸gÀç¹Î¶¤
½Ð¤j®a¤@°_¤W½×¾Â¨Ó¥æ¬y

TOP

¦^´_ 2# Andy2483
·PÁÂAndy ¤j¤j«üÂI°g¬z:lol

TOP

¥»©«³Ì«á¥Ñ Andy2483 ©ó 2023-6-15 08:36 ½s¿è

¦^´_ 3# max67424


    ÁÂÁ½׾Â,ÁÂÁ«e½ú¦^´_
«á¾Ç½Æ²ß¤F¤@¤U,½Æ²ß¤ß±oµù¸Ñ¦p¤U,½Ð«e½ú°Ñ¦Ò,½Ð¦U¦ì«e½ú«ü±Ð

Option Explicit
Public SELrr, SEL%
Sub TEST()
Application.DisplayAlerts = False
'¡ô¥Oµ{§Ç°õ¦æ¤£­n°Ý§R¤£§R(§R)
Application.ScreenUpdating = False
'¡ô¥O¿Ã¹õ¤£ÀHµ{§Ç°õ¦æµ²ªG°µÅܤÆ
Dim Brr, A, B, Z, i&, j%, xR As Range
'¡ô«Å§iÅܼÆ
A = Array(1, 2, 5, 6, 11, 15, 16, 17, 19, 22, 27, 28, 31, 35, 40)
'¡ô¥OAÅܼƬO ¤@ºû°}¦C(¯Á¤Þ¸¹0~14,³o¬O¼ÐÅÒª©«¬ªº®æ¸¹)
B = Array(2, 3, 4, 17, 5, 6, 7, 8, 9, 10, 11, 16, 12, 13, 14)
'¡ô¥OBÅܼƬO ¤@ºû°}¦C(¯Á¤Þ¸¹0~14,³o¬O¦¬®Æ¼ÐÅÒªºÄ渹)
If SEL = 1 Then Brr = SELrr Else: Brr = Range([¦¬®Æ¼ÐÅÒ!Q2], [¦¬®Æ¼ÐÅÒ!A65536].End(3))
'¡ô¦pªGSELÅܼƬO 1?,¬O´N¥OBrrÅܼƬOSELrrÅܼÆ(¤Gºû°}¦C),
'§_«h´N¥OBrrÅܼƬO ¤Gºû°}¦C,¥H¦¬®Æ¼ÐÅÒªíªºA~QÄæÀx¦s®æ­È±a¤J°}¦C¤¤

Set xR = [¼ÐÅÒª©«¬!A1:E8]
'¡ô¥OxRÅܼƬO [¼ÐÅÒª©«¬!A1:E8](ª«¥ó:Àx¦s®æ)
On Error Resume Next: Sheets("¦X¨Ö¦C¦L").Delete: On Error GoTo 0
'¡ô¥O"¦X¨Ö¦C¦L"ªí §R°£
Sheets("¼ÐÅÒª©«¬").Copy after:=Worksheets(Sheets.Count)
'¡ô¥O"¼ÐÅÒª©«¬"ªí½Æ»s¤@¥÷¨ì ¤u§@ªí¯Á¤Þ³Ì«á
With Sheets(Sheets.Count)
   .Name = "¦X¨Ö¦C¦L": .[A:E].Clear
   '¡ô¥O½Æ»sªº¤u§@ªí§ï¦W¬°"¦X¨Ö¦C¦L",¨Ã²M°£A~EÄæ
   With .DrawingObjects
      If .Count > 0 Then .Delete
   End With
   '¡ô¥O§R°£¹Ï¤ù.¹Ï®×....µ¥
End With
For i = 1 To UBound(Brr)
   If Brr(i, 5) = "" Then Exit For
   For j = 0 To UBound(A): xR(A(j)) = Brr(i, B(j)): Next
   xR(1) = xR(1) & "-": xR(16) = "­Ü:" & xR(16) & "/"
   xR(17) = "Àx:" & xR(17) & "/": xR(28) = "(" & xR(28) & ")"
   xR(40) = xR(40) & Brr(i, 15)
   xR.Copy Sheets("¦X¨Ö¦C¦L").Cells((i - 1) * 8 + 1, 1)
Next
'¡ô³]¶¶°j°é±N "¦¬®Æ¼ÐÅÒ"ªí¸ê®Æ±a¤J [¼ÐÅÒª©«¬!A1:E8]«á,
'½Æ»s¨ì "¦X¨Ö¦C¦L"ªí

SEL = 0
'¡ô¥OSELÅܼƬ° 0
Set xR = Nothing: Erase Brr, A, B
'¡ô¥OÄÀ©ñÅܼÆ
End Sub

Option Explicit
Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
With Target
   Cancel = True
   If Rows.Count = .EntireRow.Rows.Count Then Exit Sub
   If .Row = 1 Then Exit Sub
   Set SELrr = Intersect(.EntireRow, [A:Q])
   If InStr(SELrr.Address, ",") Then Exit Sub
   SEL = 1:  Call TEST
End With
End Sub
¥Î¦æ°Ê¸Ë¸mÂsÄý½×¾Â¾Ç²ß«Ü¤è«K,ÁÂÁ½׾¸gÀç¹Î¶¤
½Ð¤j®a¤@°_¤W½×¾Â¨Ó¥æ¬y

TOP

¦^´_ 4# Andy2483
·PÁÂAndy ¤j´£¨Ñµù¸Ñ¡A¾Ç²ß°_¨Ó§ó»´ÃP¤F¡C·P®¦

TOP

        ÀR«ä¦Û¦b : ¦n¨Æ­n´£±o°_¡A¬O«D­n©ñ±o¤U¡A¦¨´N§O¤H§Y¬O¦¨´N¦Û¤v¡C
ªð¦^¦Cªí ¤W¤@¥DÃD