- ©«¤l
- 1446
- ¥DÃD
- 40
- ºëµØ
- 0
- ¿n¤À
- 1470
- ÂI¦W
- 0
- §@·~¨t²Î
- Windows 7
- ³nÅ骩¥»
- Excel 2010 & 2016
- ¾\ŪÅv
- 50
- ©Ê§O
- ¨k
- ¨Ó¦Û
- ¥xÆW
- µù¥U®É¶¡
- 2020-7-15
- ³Ì«áµn¿ý
- 2024-10-21
|
¥»©«³Ì«á¥Ñ 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 |
|