點選複製

myleoyes

各位前輩你們好!
         前輩!問題如附檔說明
         請知道的前輩,不吝賜教謝謝再三!!

GBKEE

回復 1# myleoyes

1. Sub 多重分析()
   
2.     Dim Rng As Range
   
3.     With Sheet1
   
4.         Set Rng = .Range("I2").CurrentRegion
   
5.         Set Rng = .Range(Rng(2, 1), Rng(Rng.Count))
   
6.         If Not Intersect(ActiveCell, Rng) Is Nothing Then
   
7.             .[A2].Copy .Range("A" & Rows.Count).End(xlUp).Offset(1)
   
8.             .Cells(ActiveCell.Row, "I").Resize(, 7).Copy .Range("I" & Rows.Count).End(xlUp).Offset(1)
   
9.        End If
   
10.     End With
    
11. End Sub

複製代碼

myleoyes

回復 2# GBKEE
GBKEE良師你好!
　　　良師!謝謝!程式只能單選
             可否以修改有複選功能呢?  
          如附檔Leov34-2請再辛苦囉,謝謝再三!!

Hsieh

1. Sub 多重分析()
   
2.     Dim Rng As Range, A As Range
   
3.     With Sheet1
   
4.         Set Rng = .Range("I2").CurrentRegion
   
5.         r = Selection.Count
   
6.         If Not Intersect(Selection, Rng) Is Nothing Then
   
7.         Set A = .Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
   
8.             Application.Intersect(Selection.EntireRow, Rng).Copy A.Offset(, 8)
   
9.             .[A2].Copy A
   
10.             A.AutoFill A.Resize(r, 1)
    
11.        End If
    
12.     End With
    
13. End Sub

複製代碼

GBKEE

回復 3# myleoyes

1. Sub 多重分析()
   
2.     ActiveWindow.ScrollRow = 150
   
3.     Dim Rng As Range, E As Range
   
4.     With Sheet1
   
5.         Set Rng = .Range("I2").CurrentRegion
   
6.         Set Rng = .Range(Rng(2, 1), Rng(Rng.Count))
   
7.         For Each E In Selection.Rows
   
8.             If Not Intersect(E, Rng) Is Nothing Then
   
9.                 .[A2].Copy .Range("A" & Rows.Count).End(xlUp).Offset(1)
   
10.                 .Cells(E.Row, "I").Resize(, 7).Copy .Range("I" & Rows.Count).End(xlUp).Offset(1)
    
11.             End If
    
12.         Next
    
13.     End With
    
14. End Sub

複製代碼

另 Hsieh 版主 的   r = Selection.Count   修改為 r = Selection.Rows.Count 才會正確的執行

myleoyes

回復 4# Hsieh
hsieh前輩你好!
       偶像前輩!謝謝!!程式複選沒問題
       但是單選時,偵錯在此 A.AutoFill A.Resize(R, 1)
       請再麻煩一下謝謝再三!!

myleoyes

回復 5# GBKEE
GBKEE前輩你好!
     　 良師!謝謝!!程式good謝謝再三!!

兩位前輩你們好!　　
      Sub 複製()
          Dim Ar As Range, A As Range
          Set Ar = Sheet1.[B1:C9]
          Set A = Sheet1.[IV1].End(xlToLeft).Offset(, 1)
          Ar.Copy
          A.Offset(0, 0).PasteSpecial xlPasteFormats
          A.Offset(0, 0).Resize(9, 2) = Ar.Value
          Application.CutCopyMode = False
       End Sub
       複製出來的儲存格都是值
       以實際需求有出入雖經修改還是看不下去哈哈!!
       只好再麻煩前輩囉!實在歹勢辛苦囉!謝謝再三!!

Hsieh

回復 6# myleoyes


    If R>1 then A.AutoFill A.Resize(R, 1)

GBKEE

回復 7# myleoyes
是這樣嗎?

1. Sub 複製()
   
2.     With Sheet1
   
3.         .Range("B1", .[b1].End(xlDown).Offset(, 1)).Copy
   
4.         With .[IV1].End(xlToLeft).Offset(, 1)
   
5.             .PasteSpecial
   
6.             .Resize(2, 2).Value = .Resize(2, 2).Value
   
7.         End With
   
8.     End With
   
9. End Sub

複製代碼

myleoyes

回復 9# GBKEE
hsieh前輩你好!
       偶像前輩!辛苦囉!謝謝再三!

GBKEE前輩你好!
　　　良師!辛苦囉!謝謝再三!