2、5、8、11…列目を残して、後の列を全て削除したい


Excelの質問です。
今、2行目から100行目ほどにかけて、それぞれの行のセルにはデータがずらりと入っています。
2行目はLG列まで、11行目はAQ列まで、50行目はAK列までと、各行入ってるデータ数はバラバラです。

この状況におきまして。
2列目(B列)を残し、3(C)・4(D)列目を削除、5列目(E列)を残し、6(F)・7(G)列目を削除…と、2、5、8、11、14…の周期で列を残して、あとの列は全て削除したいのです。

各行でセルに入っているデータ数が違いますので。
各行「最初の空白列」に行き当たるまで、列の削除を行いたいです。

手作業でやっても30分~1時間ぐらいあればできそうなのですが、マクロや関数など、
もしスマートな方法があればお知恵をお借りしたいと思いまして。

よろしくお願いします。

回答の条件
  • 1人10回まで
  • 登録:2018/04/22 10:23:33
  • 終了:2018/04/22 20:06:02
id:moon-fondu

ちなみに1列目(A列)も残したいです。

ベストアンサー

id:Z1000S No.2

Z1000S回答回数27ベストアンサー獲得回数202018/04/22 12:13:34

ポイント1200pt

これでどうでしょうか?

Public Sub deleteColumns()

    Const TARGET_SHEET_NAME As String = "Sheet1"
    Const BEGIN_COL         As Long = 2
    Const BEGIN_ROW         As Long = 2
    Const END_ROW           As Long = 100
    Const COL_CYCLE         As Long = 3

    Dim rgDatas     As Range
    Dim lCurrentCol As Long
    Dim lDataCounts As Long

    lCurrentCol = BEGIN_COL

    With ThisWorkbook.Worksheets(TARGET_SHEET_NAME)
        Do
            '基準列の右側(次の基準列の前まで)
            Set rgDatas = .Range(.Cells(BEGIN_ROW, lCurrentCol + 1), .Cells(END_ROW, lCurrentCol + COL_CYCLE - 1))

            'データがあるセル数取得
            lDataCounts = WorksheetFunction.CountA(rgDatas)

            If lDataCounts > 0 Then
                'データがあれば列削除
                rgDatas.EntireColumn.Delete

                lCurrentCol = lCurrentCol + 1
            End If
        Loop Until (lDataCounts = 0)
    End With

    Debug.Print "Done."

End Sub
id:moon-fondu

ありがとうございます、うまく列が消えました(^^♪

2018/04/22 19:46:24
id:Z1000S

ベストアンサーありがとうございます。

2018/04/22 20:50:39

その他の回答(1件)

id:Asayuri No.1

Asayuri回答回数63ベストアンサー獲得回数142018/04/22 12:03:32

ポイント50pt

 
1.セルB102から最大列の200行目までに 次の関数式を貼り付けます
 
  =OFFSET($A2,0,(COLUMN()-2)*3+1)
 
2.セルB102から最大列の200行目までをコピーして
 
  セルB2から 最大列の100行目までに値貼り付けすることにより
 
  必要とするデータが完成します
 

id:moon-fondu

ありがとうございます、「1」はうまくいきました!
「2」なのですが、B2から100行目当たりは既にデータが入ってい状況ので、そこを絡めずにやりたいです。

2018/04/22 19:42:47
id:Z1000S No.2

Z1000S回答回数27ベストアンサー獲得回数202018/04/22 12:13:34ここでベストアンサー

ポイント1200pt

これでどうでしょうか?

Public Sub deleteColumns()

    Const TARGET_SHEET_NAME As String = "Sheet1"
    Const BEGIN_COL         As Long = 2
    Const BEGIN_ROW         As Long = 2
    Const END_ROW           As Long = 100
    Const COL_CYCLE         As Long = 3

    Dim rgDatas     As Range
    Dim lCurrentCol As Long
    Dim lDataCounts As Long

    lCurrentCol = BEGIN_COL

    With ThisWorkbook.Worksheets(TARGET_SHEET_NAME)
        Do
            '基準列の右側(次の基準列の前まで)
            Set rgDatas = .Range(.Cells(BEGIN_ROW, lCurrentCol + 1), .Cells(END_ROW, lCurrentCol + COL_CYCLE - 1))

            'データがあるセル数取得
            lDataCounts = WorksheetFunction.CountA(rgDatas)

            If lDataCounts > 0 Then
                'データがあれば列削除
                rgDatas.EntireColumn.Delete

                lCurrentCol = lCurrentCol + 1
            End If
        Loop Until (lDataCounts = 0)
    End With

    Debug.Print "Done."

End Sub
id:moon-fondu

ありがとうございます、うまく列が消えました(^^♪

2018/04/22 19:46:24
id:Z1000S

ベストアンサーありがとうございます。

2018/04/22 20:50:39

コメントはまだありません

この質問への反応(ブックマークコメント)

「あの人に答えてほしい」「この質問はあの人が答えられそう」というときに、回答リクエストを送ってみてましょう。

これ以上回答リクエストを送信することはできません。制限について

絞り込み :
はてなココの「ともだち」を表示します。
回答リクエストを送信したユーザーはいません