ここから本文です

マクロで行を詰めたい。

ovy********さん

2017/7/2418:19:20

マクロで行を詰めたい。

A列にコピペしたものをまず置き換えで「(*」→「」、「 」→「」
全角括弧開始位置からあとの文字を全部削除、次に半角空きを削除、更に空白行を削除して上に詰めて、「五十音」の「あ」・「い」・「う」~「ん」の一文字の行を削除して上に詰めていってほしいのです。図で行くと黄色の部分です。

置き換えのコードです。
Columns("A:A").Select
Selection.Replace What:="(*", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Selection.Replace What:=" ", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False

ReplaceFormat,SearchFormat,SearchOrder,xlByRows,MatchCase

閲覧数:
31
回答数:
1
お礼:
500枚

違反報告

ベストアンサーに選ばれた回答

chi********さん

2017/7/2419:00:22

> 全角括弧開始位置から
そのコードでは半角の括弧が指定されてるみたいですけど?

めんどくさいので AdvancedFilterで抽出

Dim lr As Long
Dim xKey As Variant, i As Long
Application.ScreenUpdating = False
lr = Cells(Rows.Count, 1).End(xlUp).Row
Application.DisplayAlerts = False
xKey = Split("(*,(*, ", ",")
For i = 0 To UBound(xKey)
Range("A1:A" & lr).Replace _
What:=xKey(i), _
Replacement:="", _
MatchCase:=False
Next i
Application.DisplayAlerts = True
Range("B:C").Insert Shift:=xlToRight
Range("B2").Formula = "=LEN(A2)>1"
Range("A1:A" & lr).AdvancedFilter _
Action:=xlFilterCopy, _
CriteriaRange:=Range("B1:B2"), _
CopyToRange:=Range("C1"), _
Unique:=False
Range("C1").Delete Shift:=xlUp
Columns("A:B").Delete Shift:=xlToLeft
Application.ScreenUpdating = True

質問した人からのコメント

2017/7/24 19:12:20

動作ばっちりでした。
どうもありがとうございます。

この質問につけられたタグ

みんなで作る知恵袋 悩みや疑問、なんでも気軽にきいちゃおう!

Q&Aをキーワードで検索:

Yahoo! JAPANは、回答に記載された内容の信ぴょう性、正確性を保証しておりません。
お客様自身の責任と判断で、ご利用ください。
本文はここまでです このページの先頭へ

「追加する」ボタンを押してください。

閉じる

※知恵コレクションに追加された質問は選択されたID/ニックネームのMy知恵袋で確認できます。

不適切な投稿でないことを報告しました。

閉じる