adgt回答ポイント 100pt

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

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

※ 有料アンケート・ポイント付き質問機能は2023年2月28日に終了しました。

ログインして回答する

ベストアンサー

ken3memo2016/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で探してもよかったかもしれませんが)
削除してみました。

もっと簡潔に書けそうな気もしますが、
叩き台の回答として、使ってみてください。
※他の回答者から袋叩きにされないか気にしつつ・・・
スター
- 3件のコメントを見る
- adgt 2016/05/23 23:44:57
  
  ご回答ありがとうございますm(_ _)m
  最終行取得のコードを元々のマクロにくっつけるとできました！なぜか削除されないセルには、どうやら小スペースが3つ入力されていたようなので、それも検索・削除に加えると目的は達することができました。
  
  一方、作成していただいたマクロを使ってみると「選択範囲の周囲にあるすべてのデータを確認しましたが、値を埋め込むためのパターンが見つかりませんでした。フラッシュ　フィルを使うには、結果として表示したいデータをサンプルとしていくつか入力し、フラッシュフィルを実行する別のセルをアクティブにした状態で、[フラッシュ　フィル]ボタンをもう一度クリックします。」と表示されてしまいます。
  
  マクロは本当に初心者なので、初歩的なところ（例えば貼り付け方など）で躓いていたら、教えて頂ければ幸いです。
  
  スター
- ken3memo 2016/05/24 00:21:09
  
  元のコードに追加して、
  自力で解決されたみたいでよかったです。
  私も「選択範囲の周囲にあるすべてのデータ～、[フラッシュ　フィル]ボタンをもう一度クリックします。」
  の原因はよくわからないので、
  
  コードの簡潔化が解決されていないと思うかもしれませんが、
  動くコードがよいコードなので、
  元コードに最終行を追加したコードを使い続けるのがよいと思います。
  
  私もフラッシュなんたらのメッセージが気になりますが、
  http://twilog.org/adgt33
  でコピーしたデータにはないような気もしますが・・・う～ん。
  ※広告のコードでもないし、何でしょうね？
  
  他の回答者様の技を待ちつつ失礼します。
  
  スター
- adgt 2016/05/24 22:05:37
  
  ありがとうございます！
  「動くコードがよいコード」のお言葉、勉強になります！
  
  スター

その他の回答

adgt
2016/05/27 09:11:21

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

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

ベストアンサー

ken3memo2016/05/23 01:05:03
満足100pt

adgt 2016/05/23 23:44:57

ken3memo 2016/05/24 00:21:09

adgt 2016/05/24 22:05:37

その他の回答

adgt
2016/05/27 09:11:21

この質問へのコメント

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

質問の情報

この質問のカテゴリ

この質問に含まれるキーワード

人気の質問

メニュー

PC版

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

ベストアンサー

ken3memo2016/05/23 01:05:03 満足100pt

adgt 2016/05/23 23:44:57

ken3memo 2016/05/24 00:21:09

adgt 2016/05/24 22:05:37

その他の回答

adgt 2016/05/27 09:11:21

この質問へのコメント

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

質問の情報

この質問のカテゴリ

この質問に含まれるキーワード

人気の質問

メニュー

PC版

ken3memo2016/05/23 01:05:03
満足100pt

adgt
2016/05/27 09:11:21