エクセル2003のVBAを教えてください。
次の対象データで、(1)(2)(3)の作業が出来るエクセルVBAを教えて下さい。
(1)(2)(3)個々のVBAでお願いします。
●対象データ:種類(A列)、文字(B列)、
データの行数:不特定なので、データのある最終行までとします。
●教えていただきたい項目
(1):種類だけを(C列)に取り出す。
(2):種類の先頭に空白の行を3行入れて、追加の2行目の種類(A列)に文字(B列)を入れる。
(3):種類が5行以上あるときは、5行ごとに空白行を追加する。
●対象データ
種類(A列) 文字(B列)
AA あああ
BB いいい
BB いい
BB いいい
CC うう
CC うう
DD ええええ
DD ええええ
DD ええええ
DD ええええ
DD ええええ
DD ええええ
DD ええええ
●(1)のVBAの結果(このようになるVBAを教えてください。)
(C列)
AA
BB
CC
DD
●(2)、(3)のVBAの結果(このようになるVBAを教えてください。)
種類(A列) 文字(B列)
あああ
AA あああ
いいい
BB いいい
BB いいい
BB いいい
うう
CC うう
CC うう
ええええ
DD ええええ
DD ええええ
DD ええええ
DD ええええ
DD ええええ
DD ええええ
DD ええええ
No.2ベストアンサー
- 回答日時:
それじゃこれで
Sub A3_1()
Dim i, rtn
i = 1
Do While True
rtn = WorksheetFunction.CountA(Range(Cells(i, 1), Cells(i + 5, 1)))
Select Case rtn
Case 0
Exit Sub
Case 6
Rows((i + 5) & ":" & (i + 5)).Insert Shift:=xlDown
End Select
i = i + 1
Loop
End Sub
返事が遅れました。
すばらしい完璧です。
前回の2つの回答と合わせて、今後のプログラムに応用します。
本当にありがとうございました。
No.1
- 回答日時:
VBA勉強中と言う所でしょうか?
簡単な説明も付けましたのであとはご自分で解析してください。
Sub A1()
'フィルタオプションで重複を除いただけ
Columns("A:A").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("C1"), Unique:=True
End Sub
--------------------
Sub A2()
'下から上にA列を見て行き、上のセルが違う「種類」だった時に3行挿入して挿入した2行目にB列の文字を入れる
For i = Cells(Rows.Count, 1).End(xlUp).Row To 2 Step -1
If Cells(i, 1) <> Cells(i - 1, 1) Then
Rows(i & ":" & (i + 2)).Insert Shift:=xlDown
Cells(i + 1, 1) = Cells(i + 3, 2)
End If
Next i
End Sub
--------------------
Sub A3()
'下から上にA列を見て行き、同じ「種類」が5個続いている時、下に1行挿入
For i = Cells(Rows.Count, 1).End(xlUp).Row To 6 Step -1
If WorksheetFunction.CountIf(Range(Cells(i, 1), Cells(i - 4, 1)), Cells(i, 1)) = 5 And (Cells(i - 5, 1) <> Cells(i, 1)) Then
Rows(i + 1).Insert Shift:=xlDown
End If
Next i
End Sub
回答ありがとうございます。
Sub A1()とSub A2()については、OKになりました。
しかし、Sub A3()は、同じ文字が5行以上続くときの2回目以降(10行目、15行目・・・)に空白行が入りません。相談の例題では、行が少なかったのですが、同じ文字が5行以上(100行以上)続くこともあります。
考えられることを試しましたが、今の持てる能力では出来ませんでした。同じ文字が5行以上続くときの2回目以降(10行目、15行目・・・)にも5行ごとに空白1行を入れる方法を教えてください。
Sub A1()、Sub A2()で追加した内容を記載します。
それを見れば今の実力がわかって頂けるのではと思います。
'========================================================
Sub A1()
'フィルタオプションで重複を除いただけ
'元ファイルを生かしてOKにしたプログラム(最初の2行に重複があった場合の重複削除)
Dim i As Long
Dim 重複 As Worksheet
Set 重複 = thisworkbook,Worksheets("ZOO")
With 重複
Columns("A:A").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("C1"), Unique:=True
'これでは、先頭行に2行の重複が残る
'.Cells(1,3).Delete Shift:=xlShiftUp これでは、先頭行が単独で重複していない場合、必要セルが消えてしまうのでNG
If .Cells (1,3)=.Cells(2.3) then 'もし、3列の1行目と2行目が重複していたら
.Cells (1,3).Delete Shift:=xlShiftUp '1行目を削除
End if
End with
End Sub
'=================================================================================
Sub A2()
'下から上にA列を見て行き、上のセルが違う「種類」だった時に3行挿入して挿入した2行目にB列の文字を入れる
'元ファイルを生かしてOKにしたプログラ(最初に3行を追加)
Dim i As Long
Dim 三行追加 As Worksheet
Set 三行追加 = thisworkbook,Worksheets("ZOO")
With 三行追加
For i = .Cells(Rows.Count, 1).End(xlUp).Row To 2 Step -1
If Cells(i, 1) <> Cells(i - 1, 1) Then
.Rows(i & ":" & (i + 2)).Insert Shift:=xlDown
.Cells(i + 1, 1) = Cells(i + 3, 2)
End If
Next i
'先頭に三行追加(1*3=3を1+1+1=3として計算しているのと同じ方法です。)
.Cells(1,1).EntireRow.Insert
.Cells(1,1).EntireRow.Insert
.Cells(1,1).EntireRow.Insert
'2行目の1列目に4行目の2列の文字を入れる。
.Cells(2,1)=.Cells(4,2)
End With
End Sub
'=======================================================================
Sub A3()
'ネットで探した5行ごとに空白行を入れるプログラムを利用して修正できないかと思ったのですが出来ませんでした。ネットで探したプログラムを記載します。(参考までに)
Dim i As Long
i=1
Do Until Cells (i*6)= ""
Rows (i*6). Insert (xlDown)
i=i+1
loop
End Sub
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
NG例:
CC うう
CC うう
DD ええええ
DD ええええ
DD ええええ
DD ええええ
DD ええええ
DD ええええ
DD ええええ
DD ええええ
DD ええええ
DD ええええ
DD ええええ
DD ええええ
DD ええええ
↓
DDの続く2回目以降の5行ごとの空白1行が入らない
うう
CC うう
CC うう
ええええ
DD ええええ
DD ええええ
DD ええええ
DD ええええ
DD ええええ
DD ええええ
DD ええええ
DD ええええ
DD ええええ
DD ええええ
DD ええええ
DD ええええ
DD ええええ
お探しのQ&Aが見つからない時は、教えて!gooで質問しましょう!
似たような質問が見つかりました
- Visual Basic(VBA) マクロを教えてください。 7 2023/06/01 19:47
- Visual Basic(VBA) vba 等間隔の列に対しての計算 6 2022/05/17 20:15
- Visual Basic(VBA) ExcelのVBAコードについて教えてください。 2 2023/01/23 17:13
- Excel(エクセル) エクセルデーターの並び替え 5 2022/08/06 09:59
- Access(アクセス) Accessのクエリの結果を、既存のエクセルに追加したい 2 2022/07/31 22:44
- Excel(エクセル) Excel 数行を1組とする300組ほどあるデータの項目を揃えたいです。 3 2023/01/26 19:38
- Visual Basic(VBA) VBA シート間の転記で、条件の追加コードの書き方について教えて下さい。 13 2023/02/26 09:31
- Excel(エクセル) 【vba】日付の形式が勝手に変わってしまう。 1 2022/09/29 10:54
- PHP PHP MySql 画像を取得 1 2022/06/04 14:05
- Excel(エクセル) 【困っています】VBA 追加処理の記述を教えてください。 1 2022/08/25 22:54
関連するカテゴリからQ&Aを探す
おすすめ情報
デイリーランキングこのカテゴリの人気デイリーQ&Aランキング
-
エクセルのマクロについて教え...
-
エクセルのマクロについて教え...
-
VBA listBoxについて
-
ExcelのVBAコードについて教え...
-
エクセルのマクロについて教え...
-
VBAを使用した時間管理
-
左右の表のキー位置を合わせたい
-
【VBA】マクロの入ったファイル...
-
エクセルの合計を自動で表示さ...
-
VBA 複数の各シートに行を追加...
-
VB.netのADOってなんですか?
-
VBAコードについて教えてくださ...
-
エクセルVBAの配列について
-
エクセルVBAにて =A1=B1とすれ...
-
ExcelのVBAコードについて教え...
-
VBAのコードを教えてください
-
Outlookの「受信日時」「件名」...
-
ユーザーフォームに別シートか...
-
VBAの質問になります Userform内で
-
ExcelのVBAコードについて教え...
マンスリーランキングこのカテゴリの人気マンスリーQ&Aランキング
-
Excel VBA マクロ シート名を変...
-
VBA
-
VBA 指定した回数分、別シート...
-
Outlookの「受信日時」「送信者...
-
Excelのマクロ(VBA)は、同じ...
-
郵便番号検索APIにてget Elemen...
-
outlookの受信日時、本文などを...
-
【マクロ】プルダウンが設定し...
-
引数に数値、文字列の混在
-
VBA実行後に元のセルに戻りたい
-
エクセルVBAでデータ転記
-
近似した文字列を置換するエク...
-
for 文の 繰り返し処理に使える...
-
ユーザーフォームに別シートか...
-
Excel VBAで値を変えながら、pd...
-
Outlookにて既にウィドウ単体で...
-
【VBA】マクロの入ったファイル...
-
メールの件名をデコードしたい
-
Outlookの「受信日時」「件名」...
-
VBA 何かしら文字が入っていたら
おすすめ情報