200ポイント差し上げます。エクセルのマクロについて質問します。次のマクロが欲しいです。


①選択した範囲に空白セルがあれば左詰め。
例(,はセルの区切りのつもり):
,,abc,def,ghi,,k,,j
という1行が範囲なら
abc,def,ghi,k,j
に。

②選択した範囲に空白セルがあれば上詰め。

③選択した範囲で、ある行のすぐ上に全く同じ内容の行があればその行を削除(時間がかかるので実行中の画面表示を停止させて処理。)
例("()"は改行のつもり):
abc,def,ghi,k()
abc,def,ghi,k
という2行が範囲なら
abc,def,ghi,k
に。

④選択した範囲のセル中にスペースやタブがあれば全部削除。
例:abc,def,,g , hi,kという1行が範囲なら
abc,def,,g,hi,kに。

以上4つのマクロ。お力添えよろしくお願いします。

回答の条件
  • 1人2回まで
  • 登録:2007/01/14 22:44:41
  • 終了:2007/01/15 01:25:13

ベストアンサー

id:Mook No.1

Mook回答回数1314ベストアンサー獲得回数3932007/01/15 00:13:10

ポイント200pt

こんな感じでしょうか。

Sub 空白を上詰()
    Dim rng As Range
    For Each rng In Selection
        If IsEmpty(rng.Value) = True Then
            rng.Delete shift:=xlUp
        End If
    Next
End Sub
Sub 空白を左詰()
    Dim rng As Range
    For Each rng In Selection
        If IsEmpty(rng.Value) = True Then
            rng.Delete shift:=xlToLeft
        End If
    Next
End Sub
Sub 重複削除()
    Dim rng As Range
    Set rng = Selection
    
' --- 画面更新を無効
    Application.ScreenUpdating = False
    
    
' --- 判別フラグ
    Dim sameFlag As Boolean
    
' --- 列の開始と終了位置
    Dim cs As Long
    cs = rng.Column
    Dim ce As Long
    ce = rng.Column + rng.Columns.Count - 1
    
    Dim rr As Long
    Dim cc As Long
    For rr = rng.Row + rng.Rows.Count - 1 To rng.Row + 1 Step -1
        sameFlag = True
        For cc = cs To ce
            If Cells(rr, cc).Value <> Cells(rr - 1, cc).Value Then
                sameFlag = False
                Exit For
            End If
        Next
        If sameFlag = True Then
             Range(Cells(rr, cs), Cells(rr, ce)).Delete shift:=xlUp
        End If
    Next
' --- 画面更新を有効
    Application.ScreenUpdating = True
End Sub
Sub 空白除去()
    Dim rng As Range
    Dim str as String
    For Each rng In Selection
' --- タブを除去
        str = Replace(rng.Value, vbTab, "")
' --- 半角スペースを除去
        str = Replace(str , " ", "")
' --- 全角スペースを除去
        rng.Value = Replace(str , " ", "")
    Next
End Sub
id:ReoReo7

相変わらずすばらしい腕前ですね。

プログラムも美しいです。

動きました!

2007/01/15 01:24:39
  • id:Mook
    ほめてもらった後でお恥ずかしいですが、不具合があります(削除の定石でした)。
    提示した方法だと、空白が連続している場合うまく動きませんので、下記の方法が良いかと思います。

    Sub 空白を上詰()
      Selection.SpecialCells(xlCellTypeBlanks).Delete shift:=xlUp
    End Sub

    Sub 空白を左詰()
      Selection.SpecialCells(xlCellTypeBlanks).Delete shift:=xlToLeft
    End Sub
  • id:ReoReo7
    私もそれを後から気づきました。ありがとうございました。

    それと、「半角スペース(?、少なくとも表示の上では。)」が削除できないようです。「セル中の文章の先頭にある半角スペース」あるいは「貼り付けると半角スペースに見える特殊文字」かもしれません。

    現在行っているのは、

    1)Web上にエクセル(※)からある行をコピー&ペースト
    2)Webのフォームからphpのmail()ファンクションで投稿されたものをGmailに送信
    3)Gmailからコピーしたものをエクセルに貼り付け
    4)「区切り位置」でスペースを指定
    5)Mookさんのプログラムで空白セルなどを削って(※)を再現

    です。
  • id:Mook
    コメントに気づくのが遅くてすみません。

    該当部分の文字コードを調べることはできませんか?
    コードがわかれば、対応方法もあるかと思います。

    いろいろな調べ方があると思いますが、バイナリエディタで該当部分を保存したテキストファイル(小さいファイルにしておいたほうが簡単です)を読み込んでも調べられます。

    もしお持ちでなかったら、下記などはファイルのドラッグ&ドロップを使用できるので重宝してます。
    http://cowscorpion.com/file/QuickBe.html

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

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

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

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