Board logo

標題: 點選複製 [打印本頁]
作者: myleoyes    時間: 2010-12-14 07:32     標題: 點選複製

各位前輩你們好!
         前輩!問題如附檔說明
         請知道的前輩,不吝賜教謝謝再三!!
作者: GBKEE    時間: 2010-12-14 08:45

回復 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    時間: 2010-12-14 21:33

回復 2# GBKEE
GBKEE良師你好!
　　　良師!謝謝!程式只能單選
             可否以修改有複選功能呢?  
          如附檔Leov34-2請再辛苦囉,謝謝再三!!
作者: Hsieh    時間: 2010-12-14 23:45

  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    時間: 2010-12-15 08:05

回復 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    時間: 2010-12-15 21:46

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

回復 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    時間: 2010-12-15 22:09

回復 6# myleoyes


    If R>1 then A.AutoFill A.Resize(R, 1)
作者: GBKEE    時間: 2010-12-16 12:56

回復 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    時間: 2010-12-16 20:52

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

GBKEE前輩你好!
　　　良師!辛苦囉!謝謝再三!
作者: myleoyes    時間: 2010-12-18 21:20

回復 10# myleoyes
各位前輩你們好!
         前輩!點選複製之2如附檔說明
         請知道的前輩,不吝賜教謝謝再三!!
作者: GBKEE    時間: 2010-12-19 13:43

回復 11# myleoyes
  1. Sub Ex()
  2.     Dim R As Range, Rng As Range
  3.     With ActiveSheet
  4.         For Each R In Selection
  5.             If Not Intersect(R, .Range(.[j2], .[j2].End(xlDown))) Is Nothing Then
  6.                 Set Rng = .Range("bs" & Rows.Count).End(xlUp).Offset(1)
  7.                 Rng.Value = ActiveSheet.[A2]
  8.                 Rng.Cells(1, 2) = R
  9.                 Range(R.Offset(, 2), .Cells(R.Row, "T")).SpecialCells(2).Copy Rng.Cells(1, 3)
  10.             End If
  11.         Next
  12.     End With
  13. End Sub
複製代碼
作者: myleoyes    時間: 2010-12-19 17:54

回復 12# GBKEE
GBKEE前輩你好!
　　　良師!辛苦囉!謝謝再三!



歡迎光臨 麻辣家族討論版版 (http://forum.twbts.com/)