Excelノート 7-1 コピー

HOME  検索  索引  もくじ  関数目次ージへ        次ページへ

タイトル欄のアドレスは、エクセルファンクラブの該当する頁へのリンク先です。
詳しい事は、こちらの
お願いをご覧になってください。

1  空白でエンターした時、すぐ上のセルの値をコピーするには?
2  前の行をコピーするマクロ
3  コピーモードの解除をしたいのですが
4  縦列を別なbookの横行にコピー
5  離れた複数の選択範囲に対してcopyしたい
6 Sheetを、同じBookに指定枚数一気にコピーするには
7  1行おきにコピーするには
8  複数のシートのデータを、他のシートに一気にまとめて貼り付けるには
9  セルの列名を固定した数式コピーを、オートフィルの横展開で行うには
10 セルの行名を固定し、列名を連続した数式コピーを、オートフィルの縦展開で行うには
11 フォルダ内の全てのエクセルファイルをコピーするには
12 選択範囲を、行高さ・列幅他(値、色・罫線、書式)を含めてコピーするには?
13 選択した範囲を、貼付先の行幅列幅に関係なく、そっくりそのままコピーするには?
14 1行目を1〜10行目に、2行目を11〜20行目に…………10行目を、91〜100行目にコピーするには?
15 セルの値を指定の数だけ、それぞれのセルの下にコピーするには
16 指定の行までオートフィルするには?

1 空白でエンターした時、すぐ上のセルの値をコピーするには?
http://www.ae.wakwak.com/~efc21/cgi-bin/wwwlng.cgi?print+200111/01110091.txt
  「セルのすぐ上の値をエンターキーで複写したい」 【VBAラウンジ】
http://www.keep-on.com/~excelyou/2000lng1/200005/00050024.txt
  「空白でエンターした時、すぐ上のセルの値をコピーするには?」 【編集ラウンジ】
【開始】のマクロを実行すると、「Sheet1」で空白でEnterした時、上のセルの値を入力します。
【終了】のマクロを実行すると、設定が解除されます。

Sub 開始()
 Application.OnKey "~", "OnEnterkey"
 Application.OnKey "{ENTER}", "OnEnterkey"
 End Sub
Sub 終了()
 Application.OnKey "~"
 Application.OnKey "{ENTER}"
End Sub
Private Sub OnEnterKey()
 With ActiveCell
  '「Sheet1」の1行目以外で、空白のままEnterした場合、その上のセルの値を入力する
  If ActiveSheet.Name = "Sheet1" And .Row <> 1 And .Value = "" Then .Value = .Offset(-1, 0).Value
  If Application.MoveAfterReturn Then
   On Error Resume Next
   Select Case Application.MoveAfterReturnDirection
    Case xlToLeft
     .Offset(0, -1).Activate
    Case xlToRight
     .Offset(0, 1).Activate
    Case xlUp
     .Offset(-1, 0).Activate
    Case xlDown
     .Offset(1, 0).Activate
    End Select
     On Error GoTo 0
  End If
 End With
End Sub

  このコードの使い方は、マクロの使い方(1)標準モジュールにあります。
1.標準モジュールに下記のマクロを記載します。
 Public Sub Test1()
  Dim rr As Long, cc As Integer
  rr = ActiveCell.Row
  cc = ActiveCell.Column
  If rr = 1 Then
  ' 一行目ならなにもしません。
   Cells(rr + 1, cc).Select
   Exit Sub
  End If
  If IsEmpty(Cells(rr, cc)) Then _
   Cells(rr, cc) = Cells(rr - 1, cc)
   Cells(rr + 1, cc).Select
  End Sub

  このコードの使い方は、マクロの使い方(1)標準モジュールにあります。
2.ワークシートのイベントとして、下記のマクロを記載します。
 Private Sub Worksheet_SelectionChange(ByVal Target As Excel.Range)
  Application.OnKey "~", "Test1"
  Application.OnKey "{ENTER}", "Test1"
 End Sub

  このコードの使い方は、マクロの使い方(2)該当するシートのモジュールにあります。
全て標準モジュールに貼ります。
「折り返し設定」のマクロを実行すると、Enterした時に右のセル(1行目の場合は下のセル)に移動し、
H列で折り返して、A列の下の行に移動します。
その際、A〜D列の空白セルでEnterした時は上の値をコピーします。

「折り返し解除」のマクロを実行すると、元に戻ります。
Option Explicit
Const 開始列 As Integer = 1
Const 折返列 As Integer = 8
Sub 折り返し設定()
 Application.MoveAfterReturn = False
 Application.OnKey "~", "折り返し機能"
 Application.OnKey "{ENTER}", "折り返し機能"
End Sub
Private Sub 折り返し機能()
 With ActiveCell
  If .Row = 1 Then
   Application.Goto .Offset(1)
  Else
  Select Case .Column
   Case 折返列 To 256
    Application.Goto Cells(.Row + 1, 開始列)
   Case 1 To 4
    If ActiveCell.Value = "" Then _
    .Value = .Offset(-1, 0).Value
    Application.Goto .Offset(0, 1)
   Case Else
    Application.Goto .Offset(0, 1)
  End Select
  End If
 End With
End Sub
Sub 折り返し解除()
 Application.MoveAfterReturn = True
 Application.OnKey "{ENTER}"
 Application.OnKey "~"
End Sub

  このコードの使い方は、マクロの使い方(1)標準モジュールにあります。
2 前の行をコピーするマクロ
Sub RowCopy()
 ActiveCell.Offset(-1).EntireRow.Copy ActiveCell.EntireRow
End Sub

  このコードの使い方は、マクロの使い方(1)標準モジュールにあります。
Sub ex()
 Dim rowCnt As Integer
 rowCnt = ActiveCell.Row
 Rows(rowCnt - 1).Copy Rows(rowCnt)
End Sub

  このコードの使い方は、マクロの使い方(1)標準モジュールにあります。
3 コピーモードの解除をしたいのですが
Application.CutCopyMode = False
Excel97、Excel2000 共通
【Esc】キー
4 縦列を別なbookの横行にコピー
Sub test()
 Range("A1:A5").Copy
 Workbooks("Book2").Sheets("Sheet1").Range("A1").PasteSpecial Transpose:=True
 Application.CutCopyMode = False
End Sub

  このコードの使い方は、マクロの使い方(1)標準モジュールにあります。
Excel97、Excel2000 共通
コピーした列を、他のBookで、
編集、形式を選択して貼り付け、行列を入れ替える、にチェックします。
5 離れた複数の選択範囲に対してcopyしたい
ActiveSheetのA2:A5とC2:C5を、E2からF5にまとめて貼りつけます。
Sub Test()
 Application.Union(Range(Cells(2, 1), Cells(5, 1)), Range(Cells(2, 3), Cells(5, 3))).Copy
 Range("E2").PasteSpecial
 Application.CutCopyMode = False
 Range("A2").Select
End Sub

  このコードの使い方は、マクロの使い方(1)標準モジュールにあります。
6 Sheetを、同じBookに指定枚数一気にコピーするには
Sub シート複数枚を一気にコピー()
 Dim shNum As Integer
 Dim i As Integer
 Sheets("Sheet1").Select
 shNum = Val(InputBox("アクティブシートコピーを何枚作成しますか?", _
 "枚数を整数で入力", 10))
 For i = 1 To shNum
  Sheets("Sheet1").Copy After:=Sheets("Sheet1")
 Next
End Sub

  このコードの使い方は、マクロの使い方(1)標準モジュールにあります。
7 1行おきにコピーするには
http://www.keep-on.com/~excelyou/2000lng1/200010/00100239.txt
  「コピーして1列とばしで張り付けるには?」 【編集ラウンジ】
Sub test()
 Dim i As Long, j As Long
 j = 1
 With Worksheets("Sheet1")
  For i = 1 To .Cells(Rows.Count, 1).End(xlUp).Row   
'Sheet1のA列の最終行まで処理を繰り返す
   .Rows(i).Copy Worksheets("Sheet2").Cells(j, 1)
   j = j + 2
  Next i
 End With
End Sub

  このコードの使い方は、マクロの使い方(1)標準モジュールにあります。
8 複数のシートのデータを、他のシートに一気にまとめて貼り付けるには
http://www.keep-on.com/~excelyou/2000lng1/200006/00060098.txt
  「複数シートのデータを簡単に貼り付けるには?(カット&ペースト以外で)」 【編集ラウンジ】
Sub test()
 Dim WS(1 To 5) As Worksheet
 Dim i As Long, j As Long, k As Long
 Set WS(1) = Worksheets("Sheet1")
 Set WS(2) = Worksheets("Sheet2")
 Set WS(3) = Worksheets("Sheet3")
 Set WS(4) = Worksheets("Sheet4")
 Set WS(5) = Worksheets("Sheet5")
 For i = 1 To 4
  k = WS(5).Range("A1").CurrentRegion.Rows.Count + 1
  j = WS(i).Range("A1").CurrentRegion.Rows.Count
  WS(i).Rows("2:" & j).Copy
  WS(5).Cells(k, 1).PasteSpecial Paste:=xlValues
 Next i
 WS(5).Cells(1, 1).Select
End Sub

  このコードの使い方は、マクロの使い方(1)標準モジュールにあります。
9 セルの列名を固定し、行名を連続した数式コピーを、オートフィルの横展開で行うには
http://cgi.fuji.ne.jp/~fj2094/cgi-bin5/wwwlng.cgi?print+200102/01020127.txt
  「セルの横展開」 【その他ラウンジ】
Excel97、Excel2000 共通
1. A1に#A3と入力して、これの右下の端っこで右クリックし、そのまま横にドラッグし連続データを選びます。
2. そのまま、編集、置換、検索する文字列を  #  置換え後の文字列を  =  としてすべて置換します。
10 セルの行名を固定し、列名を連続した数式コピーを、オートフィルの縦展開で行うには
1. 行番号の前に#を入れ、絶対参照にします。例えば。。。
   =B$1+$2    
2. それをいったんオートフィルで、横に展開 します。
3. 横展開した項目をコピーし、【編集】、【形式を選択して貼付】、行列を入れ替えるにチェックを入れます。
4. 「#」の文字列は、置換えによって変更します。 
11 フォルダ内の全てのエクセルファイルをコピーするには
C:\My documents\test2 のフォルダ内の、全てのエクセルファイルを
"C:\My documents\test1 のフォルダにコピーします。
Sub 全ファイルコピー()
 Dim fs
 Set fs = CreateObject("Scripting.FileSystemObject")
 fs.copyfile "C:\My documents\test2\*.xls", "C:\My documents\test1\"
End Sub

  このコードの使い方は、マクロの使い方(1)標準モジュールにあります。
12 選択範囲を、行高さ・列幅他(値、色・罫線、書式)を含めてコピーするには?
http://cgi.fuji.ne.jp/~fj2094/cgi-bin1/wwwlng.cgi?print+200109/01090127.txt
  「セル幅と高さを変えないでコピー&ペーストしたい」 【編集ラウンジ】
コピー元を選択してから実行してください。

Sub 行幅列幅を含むコピー()
 Dim RC As Long, CC As Long, R() As Single, C() As Single
 Dim i As Long, j As Long, Seru As Range
 If TypeName(Selection) <> "Range" Then
  MsgBox "先にコピー元を選んでください", vbCritical
  Exit Sub
 End If
 With Selection
  If .Areas.Count > 1 Then
   MsgBox "コピー元に複数のセル範囲は選択できません", vbCritical
   Exit Sub
  End If
  RC = .Rows.Count
  CC = .Columns.Count
  '変数の個数を設定
  ReDim R(1 To RC)
  ReDim C(1 To CC)
  '選択範囲の各行高さを変数に格納
  For i = 1 To RC
   R(i) = .Rows(i).RowHeight
  Next
  '選択範囲の各列幅を変数に格納
  For j = 1 To CC
   C(j) = .Columns(j).ColumnWidth
  Next
  On Error GoTo Er1        
'キャンセルボタンが押されたら、Er1にジャンプして終わる
  Set Seru = Application.InputBox("貼り付け先の左上のセルを指定して下さい", "セルの選択", Type:=8)
  Set Seru = Seru.Resize(RC, CC)
  Application.ScreenUpdating = False
  .Copy
                  '選択範囲をコピー(行列以外のデータ・色・罫線等)
 End With
 With Seru
  .PasteSpecial xlPasteFormats     
'書式のみ貼り付け
  .PasteSpecial xlPasteValues     
'値のみ貼り付け
  For i = 1 To RC
            '貼付元の行数だけ、繰り返す
   .Rows(i).RowHeight = R(i)      
'貼付先セルの縦幅を、貼付元セルの縦幅にする
  Next
  For j = 1 To CC '貼付元の列数だけ、繰り返す
   .Columns(j).ColumnWidth = C(j)   
'貼付先セルの横幅を、貼付元セルの横幅にする
  Next
  .Worksheet.Activate
  .Select
 End With
Er1:
 Set Seru = Nothing
 Application.CutCopyMode = False
 Application.ScreenUpdating = True
End Sub

  このコードの使い方は、マクロの使い方(1)標準モジュールにあります。

13 選択した範囲を、貼付先の行幅列幅に関係なく、そっくりそのままコピーするには?
http://cgi.fuji.ne.jp/~fj2094/cgi-bin1/wwwlng.cgi?print+200106/01060036.txt
  「作成した表をそのままの形でコピーするには?」 【編集ラウンジ】
カメラ機能
 1. 【ツール】【ユーザー設定】【コマンド】で、分類の所から【ツール】を選択し、
   コマンドの所から、【カメラ】と言う、カメラのマークのアイコンを探して、
   ツールバーの任意の場所にドラッグして配置します。
 2. コピーしたいセル範囲を選択し、ドラッグした【カメラ】のアイコンをクリックして、
   貼り付けたい場所をクリックします。
図のリンク貼り付け
 1. コピーしたい範囲を選択してコピーし、貼り付けたい場所を選択して
   Siftキーを押しながらメニューバーの編集をクリックします。
 2. メニューに、【図のリンク貼付】というのが出ますので、それをクリックします。
14 1行目を1〜10行目に、2行目を11〜20行目に…10行目を、91〜100行目にコピーするには?
http://cgi.fuji.ne.jp/~fj2094/cgi-bin1/wwwlng.cgi?print+200106/01060168.txt
  「10行のデータを100行に増やして貼り付けるには?」 【編集ラウンジ】
Excel97、Excel2000、エクセル2002 共通
2行目をコピー(行番号1をクリック)、11〜20行目を選択(行番号11〜20を選択)してペースト。
この作業を10行目まで繰り返し、最後に1行目を10行目までコピーします。
Excel97、Excel2000、エクセル2002 共通
1. A列の左に1行挿入し、A1〜A10に、1〜10の数字を入力します。
2. 1〜10行目を選択(行番号11〜20を選択)してコピーします。
3. 11〜100行目を選択し、貼り付けます。
4. 全セルを選択し(行番号の上、列番号の左をクリック)、A列をキーとして、昇順で並び替えます。
5. A列を削除します。
エクセル2002 確認済
Sub miko_test1()
 Dim i1 As Integer, i2 As Integer
 For i1 = 10 To 1 Step -1
  For i2 = i1 * 10 - 9 To i1 * 10
   Rows(i1).Copy Rows(i2)
  Next
 Next
End Sub

  このコードの使い方は、マクロの使い方(1)標準モジュールにあります。
15 セルの値を指定の数だけ、それぞれのセルの下にコピーするには
http://cgi.fuji.ne.jp/~fj2094/cgi-bin1/wwwlng.cgi?print+200111/01110131.txt
  「行をコピーするには?」 【編集ラウンジ】
A列の最終行、1列目の最終列を取得し、指定の行数分コピーして処理しますエクセル2002 確認済
Sub miko_test()
 Dim i As Long, j As Long, a As Variant, LC As Integer
 Application.ScreenUpdating = False '画面の動きを固定
 Columns("A").EntireColumn.Insert '作業列を挿入
 '1〜最終行まで通し番号をふる
 For i = 1 To Cells(Application.Rows.Count, 2).End(xlUp).Row
 Cells(i, 1) = Cells(i, 1) + i
 Next
 
'コピーの行数をインプットボックスから入力
 a = Application.InputBox(Prompt:="何行コピーしますか?", Type:=1)
 '最終列を取得
 LC = Cells(1, Application.Columns.Count).End(xlToLeft).Column
 
'最終行、最終列の範囲を、最終行の下に指定行数だけコピー
 For j = 1 To a - 1
 Range(Cells(1, 1), Cells(i, LC)).Copy Cells(j * i, 1)
 Next
 
'通し番号をキーにして、並び替え
 Range(Cells(1, 1), Cells(j * i, LC)).Sort Key1:=Range("A1"), Header:=xlGuess
 Columns("A:A").Delete Shift:=xlToLeft
'作業列を削除
 Application.ScreenUpdating = True
'画面の固定を解除
End Sub

  このコードの使い方は、マクロの使い方(1)標準モジュールにあります。
16 指定の行までオートフィルするには?
Sub オートフィル() '元のセルをひとつだけ選択してください
 Dim bb As Variant, cc As String
 On Error Resume Next
 If selection.Column > 26 Then
  cc = Left(selection.Address(False, False), 2)
 Else
  cc = Left(selection.Address(False, False), 1)
 End If
 bb = Application.InputBox(Prompt:="何行目までオートフィルしますか?", Default:=100, Type:=1)
 If MsgBox("Ctrlモードにしますか?", vbYesNo) = vbYes Then
  Range(selection.Address(False, False)).AutoFill Destination:= _
         Range(selection.Address(False, False) & ":" & cc & bb), Type:=xlFillSeries
 Else
  Range(selection.Address(False, False)).AutoFill Destination:= _
         Range(selection.Address(False, False) & ":" & cc & bb), Type:=xlFillDefault
 End If
End Sub
  このコードの使い方は、マクロの使い方(1)標準モジュールにあります。

HOME  検索  索引  もくじ  関数目次ージへ        次ページへ

このページのTOPへ

 

 

inserted by FC2 system