戻る  □一般操作のサロン  □ 使用方法  □ 新着記事  □ 新規に質問する!  □ トピック一覧  □ 検索  □ 過去ログ
[ 最新記事及び返信フォームをトピックトップへ ]
このトピック参照回数 :
複数列ごとに複数列を挿入の繰り返し

    [189348] 複数列ごとに複数列を挿入の繰り返し-

    ■親トピック/記事引用/メール受信=OFF■

    □投稿者/ ソーダバー -(2019/05/16(10:00))
    □U R L/
      6列ごとに2列の列を挿入し、GHの列をコピーして挿入した列にペースト、を
      最終列まで繰り返す。
      というマクロを作りたいので、ご教授よろしくお願いいたします。
      
      環境はWindows8,Excel2016です。
      
      
      Sub 列の挿入を繰り返す()
          
          Dim i As Long
          Dim LastColumn As Long
          
          'I列から右へ最終列を出す
          LastColumn = Range("I1").End(xlToRight).Column
          
          '6列ごとに繰り返す
          For i = LastColumn.Columns.Count To 7 Step -6
          
              '2列挿入
              Cells(1, i).EntireColumn.Insert
              'GからHの列をコピー
              Cells("G:H").EntireColumn.Copy
              '挿入した2列にコピーを貼り付ける
              Cells(1, i).EntireColumn.PasteSpecial (xlPasteAll)
          
          Next i
              
      End Sub
      


      この記事にはVBAのコードが含まれています。

      緑の太文字→注釈
      茶色の太文字→条件分岐
      赤の太文字→ループ
      青の太文字→その他




    [189350] Re[1]: 複数列ごとに複数列を挿入の繰り返し-

    記事引用/メール受信=OFF■

    □投稿者/ ソーダバー -(2019/05/16(14:46))
    □U R L/
      すいません。
      コードは今こうなっています。
      
      Sub 列の挿入を繰り返す()
          
          Dim i As Long
          Dim LastColumn As Long
          
          'I列から右へ最終列を出す
          LastColumn = Range("I1").End(xlToLeft).Column
          
          'I列から6列ごとに繰り返す
          For i = 9 To LastColumn Step -6
          
              '2列挿入
              Cells(1, i).EntireColumn.Insert
              'GからHの列をコピー
              Cells("G:H").EntireColumn.Copy
              '挿入した2列にコピーを貼り付ける
              Cells(1, i).EntireColumn.PasteSpecial (xlPasteAll)
          
          Next i
              
      End Sub


      この記事にはVBAのコードが含まれています。

      緑の太文字→注釈
      茶色の太文字→条件分岐
      赤の太文字→ループ
      青の太文字→その他




    [189351] Re[1]: 複数列ごとに複数列を挿入の繰り返し-

    記事引用/メール受信=OFF■

    □投稿者/ ひつまぶし -(2019/05/16(14:55))
    □U R L/
      Sub sample()
          
          Const SRC_COL_POS = 7       '貼り付け元開始位置(G列)
          Const SRC_COL_W = 2          '貼り付け元列数(2列)
          
          Const START_COL = 9         '挿入開始位置(I列)
          Const PASTE_STEP = 6        '貼り付けステップ(6列ごと)
          
          Dim i As Long               'カウンタ
          
          Dim src_rng As Range        '貼り付け元範囲
          
          
          Set src_rng = Columns(SRC_COL_POS).Resize(, SRC_COL_W)      '貼り付け元範囲の取得
          'src_rng.select     '貼り付け元選択(動作確認用)
          
          i = 1   'カウンタ初期化
          
          Do
          
              src_rng.Copy        '貼り付け元コピー
              
              'Columns(START_COL + PASTE_STEP * i + SRC_COL_W * (i - 1)).Resize(, SRC_COL_W).Select        '挿入位置選択(動作確認用)
              Columns(START_COL + PASTE_STEP * i + SRC_COL_W * (i - 1)).Resize(, SRC_COL_W).Insert shift:=xlToRight        '貼り付け開始位置から6行ごと(最初の1回は挿入した列数を無視)に挿入貼り付け
        
              i = i + 1       'カウンタ増加
        
              '次回挿入位置が表の列の末尾より大ならループ抜け
              'Columns(START_COL + PASTE_STEP * i + SRC_COL_W * (i - 1)).Select       '次回挿入位置選択(動作確認用)
              If START_COL + PASTE_STEP * i + SRC_COL_W * (i - 1) > Cells(1, Columns.Count).End(xlToLeft).Column + 1 Then
                  Exit Do
              End If
              
              DoEvents        'うっかり無限ループ時のキー割込みのため
        
          Loop
          
          Application.CutCopyMode = False     'コピーモード解除
          
          MsgBox "処理終了"
      
      End Sub
      


      この記事にはVBAのコードが含まれています。

      緑の太文字→注釈
      茶色の太文字→条件分岐
      赤の太文字→ループ
      青の太文字→その他




    [189352] Re[2]: 複数列ごとに複数列を挿入の繰り返し-

    記事引用/メール受信=OFF■

    □投稿者/ ソーダバー -(2019/05/16(15:08))
    □U R L/

      ひつまぶし様

      回答ありがとうございます。
      早速試してみたところ、ループがうまくいっていないのか、
      コピペが1回で終わってしまいます。




    [189353] Re[3]: 複数列ごとに複数列を挿入の繰り返し-

    記事引用/メール受信=OFF■

    □投稿者/ ソーダバー -(2019/05/16(15:41))
    □U R L/
      ひつまぶし様
      
      
      '次回挿入位置が表の列の末尾より大ならループ抜け
      Columns(START_COL + PASTE_STEP * i + SRC_COL_W * (i - 1)).Select       
      '次回挿入位置選択(動作確認用)
      If START_COL + PASTE_STEP * i + SRC_COL_W * (i - 1) > Cells(1, Columns.Count).End(xlToLeft).Column + 1 Then
      
      >>.End(xlToLeft)
      この部分をRightにしたらループはできたのですが無限ループに入ってしまいました。
      
      


      この記事にはVBAのコードが含まれています。

      緑の太文字→注釈
      茶色の太文字→条件分岐
      赤の太文字→ループ
      青の太文字→その他




    [189354] Re[4]: 複数列ごとに複数列を挿入の繰り返し-

    記事引用/メール受信=OFF■

    □投稿者/ ぴんく -(2019/05/16(15:57))
    □U R L/
      Sub 列の挿入を繰り返す()
          Dim i As Long
          Dim LastColumn As Long
          
          'I列から右へ最終列を出す
          LastColumn = Range("I1").End(xlToRight).Column
          For i = LastColumn To 7 Step -6
              '2列挿入
              Cells(1, i).Resize(, 2).EntireColumn.Insert
              'GからHの列をコピー
              Range("G:H").EntireColumn.Copy
              '挿入した2列にコピーを貼り付ける
              Cells(1, i).EntireColumn.PasteSpecial (xlPasteAll)
          Next i
      End Sub
      


      この記事にはVBAのコードが含まれています。

      緑の太文字→注釈
      茶色の太文字→条件分岐
      赤の太文字→ループ
      青の太文字→その他




    [189355] Re[5]: 複数列ごとに複数列を挿入の繰り返し-

    記事引用/メール受信=OFF■

    □投稿者/ ソーダバー -(2019/05/16(16:09))
    □U R L/

      ぴんく様

      回答ありがとうございます。
      実行しましたところアプリケーション定義またはオブジェクト定義のエラーです。

      エラー報告が出ました。




    [189356] Re[6]: 複数列ごとに複数列を挿入の繰り返し-

    記事引用/メール受信=OFF■

    □投稿者/ ぴんく -(2019/05/17(08:06))
    □U R L/
      >エラー報告が出ました。
      どの箇所で出ましたか?
      
      Sub 列の挿入を繰り返すV()
          Dim i As Long
          
          i = 15
          Do
              '2列挿入
              Cells(1, i).Resize(, 2).EntireColumn.Insert
              'GからHの列をコピー
              Range("G:H").EntireColumn.Copy
              '挿入した2列にコピーを貼り付ける
              Cells(1, i).EntireColumn.PasteSpecial (xlPasteAll)
              i = i + 8
          Loop Until Cells(1, i).Value = ""
          Application.CutCopyMode = False
      End Sub


      この記事にはVBAのコードが含まれています。

      緑の太文字→注釈
      茶色の太文字→条件分岐
      赤の太文字→ループ
      青の太文字→その他




    [189357] Re[7]: 複数列ごとに複数列を挿入の繰り返し-

    記事引用/メール受信=OFF■

    □投稿者/ ソーダバー -(2019/05/17(08:58))
    □U R L/

      ぴんく様

      返信が遅くなってしまいすみませんでした。

      >どの箇所で出ましたか?

      '2列挿入
      Cells(1, i).Resize(, 2).EntireColumn.Insert

      ここの部分でエラーが出ました。




    [189358] Re[8]: 複数列ごとに複数列を挿入の繰り返し-

    記事引用/メール受信=OFF■

    □投稿者/ ソーダバー -(2019/05/17(09:16))
    □U R L/
      ぴんく様
      
      
      こちらのコードだと、1回だけコピぺができました。
      
      
      Sub 列の挿入を繰り返すV()
          Dim i As Long
          
          i = 15
          Do
              '2列挿入
              Cells(1, i).Resize(, 2).EntireColumn.Insert
              'GからHの列をコピー
              Range("G:H").EntireColumn.Copy
              '挿入した2列にコピーを貼り付ける
              Cells(1, i).EntireColumn.PasteSpecial (xlPasteAll)
              i = i + 8
          Loop Until Cells(1, i).Value = ""
          Application.CutCopyMode = False
      End Sub


      この記事にはVBAのコードが含まれています。

      緑の太文字→注釈
      茶色の太文字→条件分岐
      赤の太文字→ループ
      青の太文字→その他




    [189359] Re[8]: 複数列ごとに複数列を挿入の繰り返し-

    記事引用/メール受信=OFF■

    □投稿者/ ぴんく -(2019/05/17(09:22))
    □U R L/

      >'2列挿入
      >Cells(1, i).Resize(, 2).EntireColumn.Insert
      >ここの部分でエラーが出ました。

      う〜ん? こちらでは原因は分からないです。他の回答をお待ちください。




    [189360] Re[9]: 複数列ごとに複数列を挿入の繰り返し-

    解決!!ありがとうございました! / 記事引用/メール受信=OFF■

    □投稿者/ ソーダバー -(2019/05/17(09:23))
    □U R L/

      ぴんく様

      少し考えましたらできました。
      ありがとうございました。




    [189361] Re[10]: 複数列ごとに複数列を挿入の繰り返し-

    記事引用/メール受信=OFF■

    □投稿者/ ソーダバー -(2019/05/17(09:24))
    □U R L/

      ひつまぶし様、ぴんく様

      お知恵をお貸しいただいてどうもありがとうございました。
      大変助かりました!



このトピック内容の全ページ数 / [0]

このトピックに書きこむ
Name/
E-Mail/

└>このツリーのレス記事をメールで受信しますか? YES/ NO/
Title/
URL/
Comment/ 通常モード->  図表モード-> (←の場合適当に改行を入れて下さい)
タグが使用できます。例 ⇒ <font color="blue">文字</font>
解決!!ありがとうございました! 解決       保留中です・・・ 保留        迷宮入りorほかあたって見ます・・ 迷宮入       すいませ〜ん。誰か〜! Help! ←※回答者専用
解決したらチェック       保留(コードテスト中など・・)         解決不可orレスが全く付かなくてほかのサイトに行くときなど・・
削除キー/
(半角8文字以内) 


- Child Forum -
Edit:ゆう-G