點選複製 - Excel程式區 - 麻辣家族討論版版

麻辣家族討論版版 » Excel程式區 » 點選複製

返回列表下一主題上一主題發帖

點選複製

超級版主 Rank: 8 Rank: 8

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

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

1^# 跳轉到 »

發表於 2010-12-14 08:45 | 顯示全部帖子

回復 1# myleoyes

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

複製代碼

超級版主 Rank: 8 Rank: 8

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

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

2^#

發表於 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 才會正確的執行

超級版主 Rank: 8 Rank: 8

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

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

3^#

發表於 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

複製代碼

超級版主 Rank: 8 Rank: 8

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

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

4^#

發表於 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

複製代碼

靜思自在 : 人生最大的成就是從失敗中站起來。

返回列表下一主題上一主題