プロが教える店舗&オフィスのセキュリティ対策術

エクセル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        ええええ

A 回答 (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
    • good
    • 0
この回答へのお礼

返事が遅れました。
すばらしい完璧です。
前回の2つの回答と合わせて、今後のプログラムに応用します。
本当にありがとうございました。

お礼日時:2012/01/22 21:14

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
    • good
    • 0
この回答へのお礼

回答ありがとうございます。
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       ええええ

お礼日時:2012/01/13 23:45

お探しのQ&Aが見つからない時は、教えて!gooで質問しましょう!