- ベストアンサー
エクセル2003のVBAを教えて
- エクセル2003のVBAを教えてください。対象データの種類を取り出すVBA、種類の先頭に空白行を追加するVBA、種類が5行以上ある場合に空白行を追加するVBAの結果を示します。
- エクセル2003のVBAを使用して対象データから種類を取り出し、空白行を追加する方法を教えてください。
- エクセル2003のVBAを使って対象データの種類を取り出し、空白行を追加する方法を教えてください。
- H45eA
- お礼率100% (12/12)
- Visual Basic
- 回答数2
- ありがとう数2
- みんなの回答 （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
その他の回答 (1)
- mt2008
- ベストアンサー率52% (885/1701)
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にしたプログラム(最初の２行に重複があった場合の重複削除) Dim i As Long Dim 重複 As Worksheet Set 重複 = thisworkbook,Worksheets("ZOO") With 重複 Columns("A:A").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("C1"), Unique:=True 'これでは、先頭行に２行の重複が残る '.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 ええええ
お礼
返事が遅れました。 すばらしい完璧です。 前回の2つの回答と合わせて、今後のプログラムに応用します。 本当にありがとうございました。