Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちら をご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。

  新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム  
12425 / 13646 ﾂﾘｰ ←次へ　｜　前へ→
▼ 【10553】列の削除と行の削除とセルの結合 あいこ 04/1/31(土) 23:23 質問
【10554】Re:列の削除と行の削除とセルの結合 とまと 04/2/1(日) 1:40 回答
【10555】Re:列の削除と行の削除とセルの結合 あいこ 04/2/1(日) 11:37 質問
【10556】Re:列の削除と行の削除とセルの結合 とまと 04/2/1(日) 12:04 回答
【10557】Re:列の削除と行の削除とセルの結合 あいこ 04/2/1(日) 14:12 質問
【10558】Re:列の削除と行の削除とセルの結合 とまと 04/2/1(日) 14:58 質問
【10561】Re:列の削除と行の削除とセルの結合 (でき... あいこ 04/2/2(月) 0:43 お礼
【10562】ありがとうございました あいこ 04/2/2(月) 0:46 お礼
【10553】列の削除と行の削除とセルの結合
質問  あいこ  - 04/1/31(土) 23:23 -
引用なし
パスワード
   皆さんこんばんは。初めて書き込み致します。
VBAはマクロ記録で作成されたコードをちょっと
編集することができるくらいの超初心者です。

下のような表がありまして、

列1 列2 列3 列4 列5 列6　...最終列 (かなり多い列数です)
AAA BB1 CCC DDD EEE FFF ...ZZ1
AAA BB2 CCC DDD EEE FFF ...ZZ2
AAA BB2 CCC DDD EEE FFF ...ZZ2
AAA BB3 CCC DDD EEE FFF ...ZZ3
AAA BB4 CCC DDD EEE FFF ...ZZ4
AAA BB1 CCC DDD EEE FFF ...ZZ1
(これもかなり多い行数です)

この中の任意の列(例 列1,列4,列6)を削除した後に
最終列のセルの文字の末尾に任意の文字(例 .datのような)を
追加して(追加する文字はすべて同じです)、
列2の重複する行を削除して、下のような結果にしたいのですが、
こういう事をVBAで処理することはできるのでしょうか。

列2 列3 列5　...最終列
BB1 CCC EEE ...ZZ1.dat
BB2 CCC EEE ...ZZ2.dat
BB3 CCC EEE ...ZZ3.dat
BB4 CCC EEE ...ZZ4.dat

手作業をマクロ記録しても、列の追加はできるのですが、
同じ内容の行が規則的に並んでいる訳ではなく、途方に
暮れています。
長い質問になってしまってすみません。
ご教授頂ければ幸いです。よろしくお願いします。
【10554】Re:列の削除と行の削除とセルの結合
回答  とまと  - 04/2/1(日) 1:40 -
引用なし
パスワード
   あいこ さん　こんばんは
１つ質問ですが、１行目は見出し行でしょうか？

Sub 重複を削除()

Dim r As Range
Dim MyR As Range

Rows("1:1").Insert Shift:=xlDown
Set MyR = Range(Range("A2").End(xlToRight), Range("A2").End(xlToRight).End(xlDown))

　　For Each r In MyR
　　　If r.Row <> 2 Then r.Value = r.Text & ".dat"　'見出し行ならこちら
　　' r.Value = r.Text & ".dat"　'すべてデータ行ならこちら
　　Next
　　　　　
　　　　　’↓２列目の重複を削除
　　　 Columns(2).AdvancedFilter xlFilterInPlace, Unique:=True
　　　　With MyR.Offset(, 1)
　　　　　　.SpecialCells(xlCellTypeVisible).Value = "削除"
　　　　　　.SpecialCells(xlCellTypeBlanks).EntireRow.Delete Shift:=xlShiftUp
　　　　　　.Clear
　　　　End With
ActiveSheet.ShowAllData

Rows("1:1").Delete Shift:=xlUp

Range("A:A,D:D,F:F").Delete Shift:=xlToLeft '列を削除

　
End Sub


コードの下記↓の部分ですが

　 For Each r In MyR
　　　 If r.Row <> 2 Then r.Value = r.Text & ".dat"　’見出し行ならこちら
　　'　r.Value = r.Text & ".dat"　'すべてデータ行ならこちら
　 Next

見出し行なら上段をそうでないなら下段を使ってください。
見出し行だとすると見出しにまで.datの文字がくっつきます。
初期設定は見出し行と仮定し上段をつかってます。
違ったらごめんなさい。
【10555】Re:列の削除と行の削除とセルの結合
質問  あいこ  - 04/2/1(日) 11:37 -
引用なし
パスワード
   とまとさん、ありがとうございます!
昨日のうちに返信が届いているなんて驚きです!
ちなみに1行目は見出しです。
きょう、早速やってみたのですが、すべての行が
処理されませんでした。
実際は何百行もあるのと、行数が一定していないのです。
最終行まで処理させるためにはどの部分を変更すれば良いのでしようか?
よろしくご教授くださいませ。

▼とまと さん：
>あいこ さん　こんばんは
>１つ質問ですが、１行目は見出し行でしょうか？
>
>Sub 重複を削除()
>
>Dim r As Range
>Dim MyR As Range
>
>Rows("1:1").Insert Shift:=xlDown
>Set MyR = Range(Range("A2").End(xlToRight), Range("A2").End(xlToRight).End(xlDown))
>
>　　For Each r In MyR
>　　　If r.Row <> 2 Then r.Value = r.Text & ".dat"　'見出し行ならこちら
>　　' r.Value = r.Text & ".dat"　'すべてデータ行ならこちら
>　　Next
>　　　　　
>　　　　　’↓２列目の重複を削除
>　　　 Columns(2).AdvancedFilter xlFilterInPlace, Unique:=True
>　　　　With MyR.Offset(, 1)
>　　　　　　.SpecialCells(xlCellTypeVisible).Value = "削除"
>　　　　　　.SpecialCells(xlCellTypeBlanks).EntireRow.Delete Shift:=xlShiftUp
>　　　　　　.Clear
>　　　　End With
> ActiveSheet.ShowAllData
>
> Rows("1:1").Delete Shift:=xlUp
>
> Range("A:A,D:D,F:F").Delete Shift:=xlToLeft '列を削除
>
>　
>End Sub
>
>
>コードの下記↓の部分ですが
>
>　 For Each r In MyR
>　　　 If r.Row <> 2 Then r.Value = r.Text & ".dat"　’見出し行ならこちら
>　　'　r.Value = r.Text & ".dat"　'すべてデータ行ならこちら
>　 Next
>
>見出し行なら上段をそうでないなら下段を使ってください。
>見出し行だとすると見出しにまで.datの文字がくっつきます。
>初期設定は見出し行と仮定し上段をつかってます。
>違ったらごめんなさい。
【10556】Re:列の削除と行の削除とセルの結合
回答  とまと  - 04/2/1(日) 12:04 -
引用なし
パスワード
   あいこさん　こんにちは（今さっき起きました）
最終行の取り方が悪かったようです。
１行目も見出しだとわかったので少し修正しました。
違ったらごめんなさい。

Sub 重複を削除()

Dim r As Range
Dim MyR As Range
Dim MyRow As Long
Dim Mycol As Long

　MyRow = ActiveSheet.UsedRange.Rows.Count
　Mycol = Range("IV1").End(xlToLeft).Column

　Application.ScreenUpdating = False '画面更新を止める
　Set MyR = Range(Cells(1, Mycol), Cells(MyRow, Mycol))

　　For Each r In MyR
　　　If r.Row <> 1 Then r.Value = r.Text & ".dat" '付け足す文字を""の中に入れる
　　Next

　　　　Columns(2).AdvancedFilter xlFilterInPlace, Unique:=True
　　　　With MyR.Offset(, 1)
　　　　　　.SpecialCells(xlCellTypeVisible).Value = "削除"
　　　　　　.SpecialCells(xlCellTypeBlanks).EntireRow.Delete Shift:=xlShiftUp
　　　　　　.Clear
　　　　End With
　　　　ActiveSheet.ShowAllData


　Range("A:A,D:D,F:F").Delete Shift:=xlToLeft '削除する列を記入
　Application.ScreenUpdating = True　'画面更新をもどす
　
End Sub
【10557】Re:列の削除と行の削除とセルの結合
質問  あいこ  - 04/2/1(日) 14:12 -
引用なし
パスワード
   とまとさん、さっそくご返信頂きありがとうございました。
でも、実行結果は変わりませんでした。
こんな感じです。
↓
番号　　　　ファイル名
10-1　　　　20030303_00011.dat
16-14　　　　20040127-20040117_00063.dat

ちなみにこの結果が出た実際の表は、列数は37個あり(列数は固定です)、
行数は198です。

列の削除の部分だけ以下のように変更したのですが、私の修正の仕方が
悪いのでしょうか。

Range("A:D,F:AJ").Delete Shift:=xlToLeft '削除する列を記入

お忙しいところすみません。

▼とまと さん：
>あいこさん　こんにちは（今さっき起きました）
>最終行の取り方が悪かったようです。
>１行目も見出しだとわかったので少し修正しました。
>違ったらごめんなさい。
>
>Sub 重複を削除()
>
>Dim r As Range
>Dim MyR As Range
>Dim MyRow As Long
>Dim Mycol As Long
>
>　MyRow = ActiveSheet.UsedRange.Rows.Count
>　Mycol = Range("IV1").End(xlToLeft).Column
>
>　Application.ScreenUpdating = False '画面更新を止める
>　Set MyR = Range(Cells(1, Mycol), Cells(MyRow, Mycol))
>
>　　For Each r In MyR
>　　　If r.Row <> 1 Then r.Value = r.Text & ".dat" '付け足す文字を""の中に入れる
>　　Next
>
>　　　　Columns(2).AdvancedFilter xlFilterInPlace, Unique:=True
>　　　　With MyR.Offset(, 1)
>　　　　　　.SpecialCells(xlCellTypeVisible).Value = "削除"
>　　　　　　.SpecialCells(xlCellTypeBlanks).EntireRow.Delete Shift:=xlShiftUp
>　　　　　　.Clear
>　　　　End With
>　　　　ActiveSheet.ShowAllData
>
>
>　Range("A:A,D:D,F:F").Delete Shift:=xlToLeft '削除する列を記入
>　Application.ScreenUpdating = True　'画面更新をもどす
>　
>End Sub
【10558】Re:列の削除と行の削除とセルの結合
質問  とまと  - 04/2/1(日) 14:58 -
引用なし
パスワード
   少し確認してください下記の
Sub 最終行の確認()で最終行を取得しているか　１９８と出るはず

Sub 最終行の確認()
　　MsgBox "最終行は " & ActiveSheet.UsedRange.Rows.Count
End Sub

　３７列というのはAK列までのことでしょうか？

あとRange("A:D,F:AJ")←これだとA列〜D列とF列〜AJ列の削除に
　　なりますがよろしいのでしょうか？
　　A列、D列、F列、AJ列の削除であれば下記のような書き方です　
　　Range("A:A,D:D,F:F,AJ:AJ")
【10561】Re:列の削除と行の削除とセルの結合 (で...
お礼  あいこ  - 04/2/2(月) 0:43 -
引用なし
パスワード
   できました!
実はきちんと伝えておけばよかったのですが、
他の行にも同じ値が多くあったのです。
ですから、全部の列と行を対象にして、同じ値をもつものを
削除すると2行しか残らないという結果は正しかったのです。
申し訳ありませんでした.....
ですので、最初に不要列を削除する処理を先に実行するように
書き換えました。以下がそれです。
(この場所が適当なのかどうかはわかりませんが、結果はきちんと
表示されました)


Sub 重複を削除()

Dim r As Range
Dim MyR As Range
Dim MyRow As Long
Dim Mycol As Long

　MyRow = ActiveSheet.UsedRange.Rows.Count
　Mycol = Range("IV1").End(xlToLeft).Column

　Application.ScreenUpdating = False '画面更新を止める
　Set MyR = Range(Cells(1, Mycol), Cells(MyRow, Mycol))
'
Range("A:D,F:AJ").Delete Shift:=xlToLeft '削除する列を記入
'
　　For Each r In MyR
　　　If r.Row <> 1 Then r.Value = r.Text & ".dat" '付け足す文字を""の中に入れる
　　Next

　　　　Columns(2).AdvancedFilter xlFilterInPlace, Unique:=True
　　　　With MyR.Offset(, 1)
　　　　　　.SpecialCells(xlCellTypeVisible).Value = "削除"
　　　　　　.SpecialCells(xlCellTypeBlanks).EntireRow.Delete Shift:=xlShiftUp
　　　　　　.Clear
　　　　End With
　　　　ActiveSheet.ShowAllData

　Application.ScreenUpdating = True　'画面更新をもどす
　
End Sub
【10562】ありがとうございました
お礼  あいこ  - 04/2/2(月) 0:46 -
引用なし
パスワード
   昨日から今日にかけて、初心者の私に懇切丁寧に
お教え下さって本当にありがとうございました。
今後ともよろしくお願い申し上げます。
  新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム  
12425 / 13646 ﾂﾘｰ ←次へ　｜　前へ→
ページ：  ┃  記事番号：
2610219
(SS)C-BOARD v3.8 is Free