點選複製

帖子: 463
主題: 116
精華: 0
積分: 580
點名: 0
作業系統: Vista
軟體版本: 2007
閱讀權限: 50
性別: 男
註冊時間: 2010-5-4
最後登錄: 2017-11-13

論壇贊助勳章論壇榮譽勳章

13^#

發表於 2010-12-19 17:54 | 只看該作者

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

GBKEE

帖子: 5923
主題: 13
精華: 1
積分: 5986
點名: 0
作業系統: win10
軟體版本: Office 2010
閱讀權限: 150
性別: 男
來自: 台灣基隆
註冊時間: 2010-5-1
最後登錄: 2022-1-23

2017 雞年全勤獎章 2016猴年全勤獎章 2015羊年全勤獎章 2014馬年全勤獎章 2013蛇年全勤獎章 2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章 2011兔年全勤獎章

12^#

發表於 2010-12-19 13:43 | 只看該作者

回復 11# myleoyes

Sub Ex()
Dim R As Range, Rng As Range
With ActiveSheet
For Each R In Selection
If Not Intersect(R, .Range(.[j2], .[j2].End(xlDown))) Is Nothing Then
Set Rng = .Range("bs" & Rows.Count).End(xlUp).Offset(1)
Rng.Value = ActiveSheet.[A2]
Rng.Cells(1, 2) = R
Range(R.Offset(, 2), .Cells(R.Row, "T")).SpecialCells(2).Copy Rng.Cells(1, 3)
End If
Next
End With
End Sub

複製代碼

帖子: 463
主題: 116
精華: 0
積分: 580
點名: 0
作業系統: Vista
軟體版本: 2007
閱讀權限: 50
性別: 男
註冊時間: 2010-5-4
最後登錄: 2017-11-13

論壇贊助勳章論壇榮譽勳章

11^#

發表於 2010-12-18 21:20 | 只看該作者

回復 10# myleoyes
各位前輩你們好!
前輩!點選複製之2如附檔說明
請知道的前輩,不吝賜教謝謝再三!!

Leov36.rar (8.26 KB)

帖子: 463
主題: 116
精華: 0
積分: 580
點名: 0
作業系統: Vista
軟體版本: 2007
閱讀權限: 50
性別: 男
註冊時間: 2010-5-4
最後登錄: 2017-11-13

論壇贊助勳章論壇榮譽勳章

10^#

發表於 2010-12-16 20:52 | 只看該作者

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

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

GBKEE

帖子: 5923
主題: 13
精華: 1
積分: 5986
點名: 0
作業系統: win10
軟體版本: Office 2010
閱讀權限: 150
性別: 男
來自: 台灣基隆
註冊時間: 2010-5-1
最後登錄: 2022-1-23

2017 雞年全勤獎章 2016猴年全勤獎章 2015羊年全勤獎章 2014馬年全勤獎章 2013蛇年全勤獎章 2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章 2011兔年全勤獎章

9^#

發表於 2010-12-16 12:56 | 只看該作者

回復 7# myleoyes
是這樣嗎?

Sub 複製()
With Sheet1
.Range("B1", .[b1].End(xlDown).Offset(, 1)).Copy
With .[IV1].End(xlToLeft).Offset(, 1)
.PasteSpecial
.Resize(2, 2).Value = .Resize(2, 2).Value
End With
End With
End Sub

複製代碼

Hsieh

帖子: 4901
主題: 44
精華: 24
積分: 4916
點名: 261
作業系統: Windows 7
軟體版本: Office 20xx
閱讀權限: 150
性別: 男
來自: 台北
註冊時間: 2010-4-30
最後登錄: 2025-10-24

2024年全勤獎章 2023年全勤獎章 2022虎年全勤獎章 2021牛年全勤獎章 2020鼠年全勤獎章 2019 豬年全勤獎章 2018 狗年全勤獎章 2017 雞年全勤獎章 2016猴年全勤獎章 2015羊年全勤獎章 2014馬年全勤獎章 2013蛇年全勤獎章 2012龍年全勤獎章論壇貢獻勳章熱心公益勳章 2011兔年全勤獎章

8^#

發表於 2010-12-15 22:09 | 只看該作者

回復 6# myleoyes

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

學海無涯_不恥下問

帖子: 463
主題: 116
精華: 0
積分: 580
點名: 0
作業系統: Vista
軟體版本: 2007
閱讀權限: 50
性別: 男
註冊時間: 2010-5-4
最後登錄: 2017-11-13

論壇贊助勳章論壇榮譽勳章

7^#

發表於 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
   複製出來的儲存格都是值
   以實際需求有出入雖經修改還是看不下去哈哈!!
   只好再麻煩前輩囉!實在歹勢辛苦囉!謝謝再三!!

Leov35.rar (10.9 KB)

帖子: 463
主題: 116
精華: 0
積分: 580
點名: 0
作業系統: Vista
軟體版本: 2007
閱讀權限: 50
性別: 男
註冊時間: 2010-5-4
最後登錄: 2017-11-13

論壇贊助勳章論壇榮譽勳章

6^#

發表於 2010-12-15 21:46 | 只看該作者

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

GBKEE

帖子: 5923
主題: 13
精華: 1
積分: 5986
點名: 0
作業系統: win10
軟體版本: Office 2010
閱讀權限: 150
性別: 男
來自: 台灣基隆
註冊時間: 2010-5-1
最後登錄: 2022-1-23

2017 雞年全勤獎章 2016猴年全勤獎章 2015羊年全勤獎章 2014馬年全勤獎章 2013蛇年全勤獎章 2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章 2011兔年全勤獎章

5^#

發表於 2010-12-15 08:05 | 只看該作者

回復 3# myleoyes

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

複製代碼

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