| |
Ctrlを押しながら、飛び飛びに選択したセルを同ブックの別シートの同じ位置にコピペします。
尚、結合セルが混ざった場合、選択したセル範囲の１つに結合セルと、結合セル以外が混成した場合はエラーになります。
結合セルを単体で選択（１つの結合セルを１範囲と考えて）すれば大丈夫なようですが？？...。
********************************
Sub 連続していないセルを別シートの同じ所にコピペ()
Dim SelRg As Range, Rg As Range, ShName As Range
Dim WbSt As String, ShSt As String, HidChkR As Long, HidChkC As Long
HidChkR = Columns(1).SpecialCells(xlCellTypeVisible).Rows.Count
HidChkC = Rows(1).SpecialCells(xlCellTypeVisible).Columns.Count
If HidChkR <> Rows.Count Or HidChkC <> Columns.Count Then
MsgBox "非表示セルには対応してません。", vbExclamation
Exit Sub
End If
Set SelRg = Selection
On Error Resume Next
Set ShName = Application.InputBox(Prompt:="コピー先シートのセル（どこで良い）を選択して下さい。", _
Title:="シートの選択", Type:=8)
On Error GoTo 0
If ShName Is Nothing Then
MsgBox "キャンセル"
Exit Sub
End If
Shad = ShName.Address(External:=True)
Shad = Application.Substitute(Shad, "'", "")
WbSt = Mid$(Shad, 2, InStr(1, Shad, "]") - 2)
ShSt = Mid$(Shad, InStr(1, Shad, "]") + 1)
ShSt = Left$(ShSt, InStr(1, ShSt, "!") - 1)
Workbooks(WbSt).Activate
Workbooks(WbSt).Sheets(ShSt).Activate
Application.ScreenUpdating = False
For Each Rg In SelRg.Areas
Rg.Copy
Workbooks(WbSt).Worksheets(ShSt).Range(Rg.Address).PasteSpecial
'↓値だけ貼り付け。（選択したセル範囲の１つに結合セルと結合セル以外が混成した場合不可）
'Sheets(ShSt).Range(Rg.Address).PasteSpecial (xlPasteValues)
cnt = cnt + 1
Next
Application.CutCopyMode = False
Application.ScreenUpdating = True
Set SelRg = Nothing
MsgBox "終了 " & cnt
End Sub
********************************
Sub オートフィルタ用コピペ()
Dim Rg As Range, ShName As Range, CpyCl As String
Dim WbSt As String, ShSt As String, ShRow As Long
Dim SelRw As Long, ShRw As Long, ShCl As Long, FilRgSt As String
Dim ACBkNm As String, ACShNm As String, CNT As Long
Dim KKct As Long
If ActiveSheet.AutoFilterMode = False Then
MsgBox "オートフィルタ用", vbExclamation
Exit Sub
End If
ACBkNm = ActiveWorkbook.Name
ACShNm = ActiveSheet.Name
FilRgSt = Workbooks(ACBkNm).Sheets(ACShNm).AutoFilter.Range.Address(0, 0)
With Workbooks(ACBkNm).Sheets(ACShNm).Range(FilRgSt)
SelRw = .Resize(.Rows.Count - 1).Offset(1).Columns(1). _
SpecialCells(xlCellTypeVisible).Row
End With
CpyCl = InputBox("フィルタ範囲の何列目をコピーしますか？", 1, 1)
If CpyCl = "" Then
MsgBox "キャンセル", vbInformation
Exit Sub
End If
On Error Resume Next
Set ShName = Application.InputBox(Prompt:="コピー先シートのセルを選択して下さい。", _
Title:="シートの選択", Type:=8)
On Error GoTo 0
DoEvents
'Workbooks(ACBkNm).Sheets(ACShNm).Select
If ShName Is Nothing Then
MsgBox "キャンセル", vbInformation
Set ShName = Nothing
Exit Sub
ElseIf ShName.Count > 1 Then
MsgBox "選択セルは１個だけ。", vbExclamation
Set ShName = Nothing
Exit Sub
End If
Shad = ShName.Address(External:=True)
Shad = Application.Substitute(Shad, "'", "")
KKct = InStr(1, Shad, "[") + 1
WbSt = Mid$(Shad, KKct, InStr(1, Shad, "]") - KKct)
ShSt = Mid$(Shad, InStr(1, Shad, "]") + 1)
ShSt = Left$(ShSt, InStr(1, ShSt, "!") - 1)
ShRw = ShName.Row
PstRg = ShName.Address(0, 0)
Workbooks(WbSt).Sheets(ShSt).Activate
With Application
If .Calculation = xlAutomatic Then
.Calculation = xlManual
CalFLG = True
End If
.ScreenUpdating = False
End With
With Workbooks(ACBkNm).Sheets(ACShNm).Range(FilRgSt)
For Each Rg In .Resize(.Rows.Count - 1).Offset(1).Columns(1). _
SpecialCells(xlCellTypeVisible).Areas
OfsR = Rg.Row - SelRw
Rg.Offset(, CpyCl - 1).Copy
Range(PstRg).Offset(OfsR).Select
Workbooks(WbSt).Worksheets(ShSt).Range(PstRg).Offset(OfsR).PasteSpecial (xlPasteValues)
CNT = CNT + Rg.Rows.Count
Next
End With
With Application
.CutCopyMode = False
.ScreenUpdating = True
If CalFLG = True Then
.Calculation = xlAutomatic
End If
End With
Set ShName = Nothing
MsgBox CNT & "件終了"
End Sub
*****************************
ＰＳ
MsgBox ActiveCell.Address
って、VBエディタ上から実行するとアドレスが取得できないときがあるんですね．．．。
MsgBox ActiveCell.Address(External:=True)
って、シート名の先頭に数字が付いている物と付いていない物とでは、アドレスの取得パターンが変わるんですね．．．。
先頭が数字だと、こんな感じにブックシート名の前後にシングルクォーテーションが付く。
'[Book1]５Sheet2'!$A$3
ＰＣがいかれているのか解りませんが知らなかった．．．．。
by Win98se & EXCEL2000SR-1
|
|
Jaka
- 06/3/13(月) 11:16 -
![[未読]](./data/FAQ/image/read_icon.gif){kind=icon}
≪
