人力検索はてな
モバイル版を表示しています。PC版はこちら
i-mobile

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つのマクロ。お力添えよろしくお願いします。

●質問者: ReoReo7
●カテゴリ:ウェブ制作
✍キーワード:ABC def エクセル セル ポイント
○ 状態 :終了
└ 回答数 : 1/1件

▽最新の回答へ

1 ● Mook
●200ポイント ベストアンサー

こんな感じでしょうか。

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
◎質問者からの返答

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

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

動きました!

関連質問


●質問をもっと探す●



0.人力検索はてなトップ
8.このページを友達に紹介
9.このページの先頭へ
対応機種一覧
お問い合わせ
ヘルプ/お知らせ
ログイン
無料ユーザー登録
はてなトップ