【マクロに関する質問】コードを修正してください。

twitterで文を書き、Twilogからそれをエクセルにコピーし、ワードへ貼り付けるためにマクロを書きました。この目的は、Ctrl + eで①余分な行を削除し、②行をつめ、③コピーをすることです。アカウント名とpostedを含む行、空白セルを含む行を削除し、A行をコピーしています。【私の要望】①より簡潔にコードを修正してください。②全ての空白セルをつめたいのですが、なぜか1行空いてしまいます。③A列をコピーした場合、余計な範囲もコピーしてしまいます。過不足ない範囲選択とコピーのしかたを教えてください。  http://twilog.org/adgt33

Sub ()
' Macro1 Macro
' Keyboard Shortcut: Ctrl+e

ActiveSheet.PasteSpecial Format:="テキスト", Link:=False, DisplayAsIcon:= _
Sheets("Sheet1").Select

Do While (True)
Columns("A:A").Select
Set mySelect = Selection.Find(What:="*@adgt33*")
If mySelect Is Nothing Then Exit Do
Rows(mySelect.Row).Select
Selection.Delete Shift:=xlUp
Loop

Do While (True)
Columns("A:A").Select
Set mySelect = Selection.Find(What:="*posted*")
If mySelect Is Nothing Then Exit Do
Rows(mySelect.Row).Select
Selection.Delete Shift:=xlUp
Loop

Columns("A").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
Columns("A").Copy

End Sub

回答の条件
  • 1人2回まで
  • 13歳以上
  • 登録:2016/05/22 01:18:45
  • 終了:2016/06/18 05:10:45

ベストアンサー

id:ken3memo No.1

ken3memo回答回数241ベストアンサー獲得回数742016/05/23 01:05:03

ポイント100pt
Sub ctrl_E()

 ' Macro1 Macro
 ' Keyboard Shortcut: Ctrl+e

'念のため、先にsheets1のA列をクリアする
 Sheets("Sheet1").Select
 Columns("A:A").ClearContents
 Range("A1").Select

'クリップボードのデータをテキスト形式で貼り付け
 ActiveSheet.PasteSpecial Format:="テキスト", Link:=False, DisplayAsIcon:= _
 Sheets("Sheet1").Select

'A列の最後の行を求める
'隣質問の回答 http://q.hatena.ne.jp/1463826490#a1256732 を参考にして
last_row = Cells(Rows.Count, 1).End(xlUp).Row

'後ろの行から消していく
For y = last_row To 1 Step -1  'yに最終行を代入して、step-1で減らしながら処理する
    Delete_Flg = 0  'フラグをゼロでクリア
    
    chkDATA = Trim("" & Cells(y, "A").Value) 'y行目のA列の値を取得
    '削除したいデータか判断する
    If Len(chkDATA) = 0 Then Delete_Flg = 1              '長さが0なら削除
    If Right(chkDATA, 6) = "adgt33" Then Delete_Flg = 1  '後ろ(右端)がadgt33で終わっていれば
    If Left(chkDATA, 6) = "posted" Then Delete_Flg = 1   '先頭(左端)がpostedなら
    If Left(chkDATA, 6) = "source" Then Delete_Flg = 1   '先頭(左端)がsourceなら
    
    '上記↑判断でフラグが立っているか判断
    If Delete_Flg = 1 Then
        Cells(y, "A").Delete Shift:=xlUp  '削除、上方向に詰める
    End If
    '↑上方向に詰めたかったので、後ろ、最終行から上にさかのぼってチェックして
    '削除該当データなら消してみた
    
Next

'削除されていると、最終行が変わっているので、
'改めて、最終行を求める
'隣質問の回答 http://q.hatena.ne.jp/1463826490#a1256732 を参考にして
last_row = Cells(Rows.Count, 1).End(xlUp).Row

'A1先頭からA最終行までを選択コピー
Range("A1:A" & last_row).Copy

End Sub

他の質問
http://q.hatena.ne.jp/1463826490#a1256732
を参考にすると、最終行が取得できるので、
後ろからforで回して、
下から上にチェックしていくイメージで、
不必要なデータをleftやrightで判断して
(instrで探してもよかったかもしれませんが)
削除してみました。

もっと簡潔に書けそうな気もしますが、
叩き台の回答として、使ってみてください。
※他の回答者から袋叩きにされないか気にしつつ・・・

他1件のコメントを見る
id:ken3memo

元のコードに追加して、
自力で解決されたみたいでよかったです。
私も 「選択範囲の周囲にあるすべてのデータ ~ 、[フラッシュ フィル]ボタンをもう一度クリックします。」
の原因はよくわからないので、

コードの簡潔化が解決されていないと思うかもしれませんが、
動くコードがよいコードなので、
元コードに最終行を追加したコードを使い続けるのがよいと思います。

私もフラッシュなんたらのメッセージが気になりますが、
http://twilog.org/adgt33
でコピーしたデータにはないような気もしますが・・・う~ん。
※広告のコードでもないし、何でしょうね?

他の回答者様の技を待ちつつ失礼します。

2016/05/24 00:21:09
id:adgt

ありがとうございます!
「動くコードがよいコード」のお言葉、勉強になります!

2016/05/24 22:05:37

その他の回答(0件)

id:ken3memo No.1

ken3memo回答回数241ベストアンサー獲得回数742016/05/23 01:05:03ここでベストアンサー

ポイント100pt
Sub ctrl_E()

 ' Macro1 Macro
 ' Keyboard Shortcut: Ctrl+e

'念のため、先にsheets1のA列をクリアする
 Sheets("Sheet1").Select
 Columns("A:A").ClearContents
 Range("A1").Select

'クリップボードのデータをテキスト形式で貼り付け
 ActiveSheet.PasteSpecial Format:="テキスト", Link:=False, DisplayAsIcon:= _
 Sheets("Sheet1").Select

'A列の最後の行を求める
'隣質問の回答 http://q.hatena.ne.jp/1463826490#a1256732 を参考にして
last_row = Cells(Rows.Count, 1).End(xlUp).Row

'後ろの行から消していく
For y = last_row To 1 Step -1  'yに最終行を代入して、step-1で減らしながら処理する
    Delete_Flg = 0  'フラグをゼロでクリア
    
    chkDATA = Trim("" & Cells(y, "A").Value) 'y行目のA列の値を取得
    '削除したいデータか判断する
    If Len(chkDATA) = 0 Then Delete_Flg = 1              '長さが0なら削除
    If Right(chkDATA, 6) = "adgt33" Then Delete_Flg = 1  '後ろ(右端)がadgt33で終わっていれば
    If Left(chkDATA, 6) = "posted" Then Delete_Flg = 1   '先頭(左端)がpostedなら
    If Left(chkDATA, 6) = "source" Then Delete_Flg = 1   '先頭(左端)がsourceなら
    
    '上記↑判断でフラグが立っているか判断
    If Delete_Flg = 1 Then
        Cells(y, "A").Delete Shift:=xlUp  '削除、上方向に詰める
    End If
    '↑上方向に詰めたかったので、後ろ、最終行から上にさかのぼってチェックして
    '削除該当データなら消してみた
    
Next

'削除されていると、最終行が変わっているので、
'改めて、最終行を求める
'隣質問の回答 http://q.hatena.ne.jp/1463826490#a1256732 を参考にして
last_row = Cells(Rows.Count, 1).End(xlUp).Row

'A1先頭からA最終行までを選択コピー
Range("A1:A" & last_row).Copy

End Sub

他の質問
http://q.hatena.ne.jp/1463826490#a1256732
を参考にすると、最終行が取得できるので、
後ろからforで回して、
下から上にチェックしていくイメージで、
不必要なデータをleftやrightで判断して
(instrで探してもよかったかもしれませんが)
削除してみました。

もっと簡潔に書けそうな気もしますが、
叩き台の回答として、使ってみてください。
※他の回答者から袋叩きにされないか気にしつつ・・・

他1件のコメントを見る
id:ken3memo

元のコードに追加して、
自力で解決されたみたいでよかったです。
私も 「選択範囲の周囲にあるすべてのデータ ~ 、[フラッシュ フィル]ボタンをもう一度クリックします。」
の原因はよくわからないので、

コードの簡潔化が解決されていないと思うかもしれませんが、
動くコードがよいコードなので、
元コードに最終行を追加したコードを使い続けるのがよいと思います。

私もフラッシュなんたらのメッセージが気になりますが、
http://twilog.org/adgt33
でコピーしたデータにはないような気もしますが・・・う~ん。
※広告のコードでもないし、何でしょうね?

他の回答者様の技を待ちつつ失礼します。

2016/05/24 00:21:09
id:adgt

ありがとうございます!
「動くコードがよいコード」のお言葉、勉強になります!

2016/05/24 22:05:37
id:adgt

質問者から

adgt2016/05/27 23:26:10

教えて頂いた内容を含めてブログにまとめました。
http://ourenzu.com/20160527/1911.html

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

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

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

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

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