目安箱 IV

目安箱投稿のルールはこちらをごらんください。
ご意見は電子メールで承っています。
「目安箱」は質問禁止です。技術的な質問はそれぞれの質問箱へどうぞ。

迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。

  新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃ホーム  
67 / 109 ツリー ←次へ | 前へ→

【142】飛び飛びセルのコピペ Jaka 06/3/13(月) 11:16 Excel[未読]

【142】飛び飛びセルのコピペ
Excel  Jaka  - 06/3/13(月) 11:16 -

引用なし
パスワード
   Ctrlを押しながら、飛び飛びに選択したセルを同ブックの別シートの同じ位置にコピペします。

尚、結合セルが混ざった場合、選択したセル範囲の1つに結合セルと、結合セル以外が混成した場合はエラーになります。
結合セルを単体で選択(1つの結合セルを1範囲と考えて)すれば大丈夫なようですが??...。

********************************
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
    '↓値だけ貼り付け。(選択したセル範囲の1つに結合セルと結合セル以外が混成した場合不可)
    '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 "選択セルは1個だけ。", 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

*****************************
PS
MsgBox ActiveCell.Address
って、VBエディタ上から実行するとアドレスが取得できないときがあるんですね...。

MsgBox ActiveCell.Address(External:=True)
って、シート名の先頭に数字が付いている物と付いていない物とでは、アドレスの取得パターンが変わるんですね...。
先頭が数字だと、こんな感じにブックシート名の前後にシングルクォーテーションが付く。
'[Book1]5Sheet2'!$A$3

PCがいかれているのか解りませんが知らなかった....。
by Win98se & EXCEL2000SR-1

  新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃ホーム  
67 / 109 ツリー ←次へ | 前へ→
ページ:  ┃  記事番号:   
0
(SS)C-BOARD v3.8 is Free