[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『VBA:違うアルファベットは残す』（いまちゃん）
昨日に続いてまたまた教えて下さい。
A A1,A3-5,A10 A11-20,A22,B1-5
上記のようなデータがある場合、結果を
A A1,3-5,10 A11-20,22,B1-5
と、先頭と同じアルファベットは先頭のみ残して削除し、先頭のアルファベット
と違う場合はアルファベットを残すようにしたいです。
下記のようなデータの場合も同じようにしたいです。
A AB1,AB3-5,AB10 A11-20,A22,BB1-5,A23-25
のデータを
A AA1,3-5,10 A11-20,22,BB1-5,A23-25
下記が作成したコードです。
Dim MAE As String Dim ATO As String Dim R As Range Dim i As Integer On Error Resume Next For aa = 1 To Cells(65536, 1).End(xlUp).Row If Len(Cells(aa, 2)) = 0 Then GoTo MUSI i = 1 Do Until Asc(Mid(Cells(aa, 2), i, 1)) = 44 _ Or Asc(Mid(Cells(aa, 2), i, 1)) = 45 _ Or i = Len(Cells(aa, 2)) i = i + 1 Loop MAE = Left(Cells(aa, 2), i) ATO = Application.Substitute(Cells(aa, 2), MAE, "", 1) ATO = Application.Substitute(ATO, "A", "") ATO = Application.Substitute(ATO, "B", "") ATO = Application.Substitute(ATO, "C", "") ATO = Application.Substitute(ATO, "D", "") ATO = Application.Substitute(ATO, "E", "") ATO = Application.Substitute(ATO, "F", "") ATO = Application.Substitute(ATO, "G", "") ATO = Application.Substitute(ATO, "H", "") ATO = Application.Substitute(ATO, "I", "") ATO = Application.Substitute(ATO, "J", "") ATO = Application.Substitute(ATO, "K", "") ATO = Application.Substitute(ATO, "L", "") ATO = Application.Substitute(ATO, "M", "") ATO = Application.Substitute(ATO, "N", "") ATO = Application.Substitute(ATO, "O", "") ATO = Application.Substitute(ATO, "P", "") ATO = Application.Substitute(ATO, "Q", "") ATO = Application.Substitute(ATO, "R", "") ATO = Application.Substitute(ATO, "S", "") ATO = Application.Substitute(ATO, "T", "") ATO = Application.Substitute(ATO, "U", "") ATO = Application.Substitute(ATO, "V", "") ATO = Application.Substitute(ATO, "W", "") ATO = Application.Substitute(ATO, "X", "") ATO = Application.Substitute(ATO, "Y", "") ATO = Application.Substitute(ATO, "Z", "") Cells(aa, 2) = MAE & ATO MUSI: Next 先頭のアルファベットと他が全て一緒の場合はうまく行くのですが、 違うアルファベットがはいっている場合がでてきてしまったので困ってしまいました。 どなたか良い回答お願いしますm(_ _)m
う〜〜〜ん！！なんだか、よくわからないけど、その例題はあってるの？？？
A1,3-5,10
A11-20,22,B1-5
最初の方は同じになったけど、二番目のはこんな感じになりました。どうかな？
AB1,B3-5,B10
A11-20,22,BB1-5,23-25
もしも、違ってたら許してということで、、
まぁ、、ご参考程度にね(^^;; ヒヤアセ
でもなんか例題おかしくない？？？
v(=∩_∩=)v
（SoulMan）
Sub 重複文字削除()
Dim MyA As Variant, MyAry() As Variant
Dim MyLen As Long, MyKey As String, MyItem As String
Dim i As Long, j As Long, k As Long
With Worksheets("Sheet1")
MyA = .Range("A1", .Range("A65536").End(xlUp)).Value
If IsEmpty(MyA) Then Exit Sub
ReDim Preserve MyAry(1 To UBound(MyA, 1), 1 To UBound(MyA, 2))
For i = 1 To UBound(MyA, 1)
k = k + 1
MyItem = ""
MyLen = Len(MyA(i, 1))
For j = 1 To MyLen
MyA(i, 1) = StrConv(MyA(i, 1), vbNarrow)
MyKey = Mid(MyA(i, 1), j, 1)
If Asc(MyKey) >= 65 And Asc(MyKey) <= 90 Then
If MyItem = "" Then
MyItem = MyKey
MyAry(i, 1) = MyAry(i, 1) + MyKey
Else
If MyItem <> MyKey Then
MyAry(i, 1) = MyAry(i, 1) + MyKey
End If
End If
Else
MyAry(i, 1) = MyAry(i, 1) + MyKey
End If
Next
Next
End With
With Worksheets("Sheet2")
.Columns(1).Cells.ClearContents
.Range("A1:A" & UBound(MyA, 1)).Value = MyAry
.Columns.AutoFit
End With
Erase MyA, MyAry
End Sub
>先頭のアルファベットと違う場合はアルファベットを残すようにしたいです。 と最初に言っているけど、多分 「直前のアルファベットと違う場合はアルファベットを残すようにしたいです」 なんですかね。且つ、アルファベットは1文字とは限らない。 だから >A11-20,22,BB1-5,A23-25 が正解で、 >A11-20,22,BB1-5,23-25 となっちゃ駄目なんでしょう。
>AB1,AB3-5,AB10 が >AA1,3-5,10 になるってのは確かに >なんか例題おかしくない？？？ って感じ。 とりあえずいまちゃん向けのアドバイスとして、 カンマが区切り文字として使われているんだから、カンマを頼りに項目を分ける。 分けた上で、各項目の最初のアルファベットだけを取り出す。 そして比較。 そんな感じで考えると良いんじゃないでしょうか。 ある特定の文字の位置を探し出す関数はInStrってのがありますし、 ある文字を区切り文字として別々にするならSplitって関数もあります。 前回、[[20041007131915]]にて提示したコードについてもじっくり見て見てください。 使える部分とかあると思うし。 そういった処理が動くコードを書くのはたやすいけど、 今後、それに関する全ての動きをこの学校に頼って作るのもアレだし。 幸いSoulManさんも参考に、とコードを提示してくれてます。 もーちょっと考えて見る時間は無いですか。 （ご近所PG）
なんだか昔、似たようなのがあったきがしたので探してみました。 結局↓も解決したのかしないのか（汗）... （ramrun）
[[20040415165539]] 『VBA：文字列の分割＆まとめる』(わからず)
とりあえず一例を。私ならこうする的な。
〜〜〜〜ここから〜〜〜〜
Sub sub適当()
'変数宣言
Dim aa As Long
Dim strWk As String
Dim strA() As String
Dim strKategori As String
Dim strPreKategori As String
Dim i As Integer
'A列の値が入っている最終行までループ
For aa = 1 To Cells(65536, 1).End(xlUp).Row
strWk = Cells(aa, 2).Value 'B列の値を取得
If strWk = "" Then GoTo MUSI '空なら無視
'初期化
strPreKategori = ""
Erase strA
strA() = Split(strWk, ",") 'カンマで区切られた文字列を配列化
'カンマで区切られた文字列全てについて処理
For i = LBound(strA) To UBound(strA)
strKategori = fncGetKategori(strA(i)) 'カテゴリ取得
If strKategori = strPreKategori Then '直前のカテゴリと一致しているなら
strA(i) = Mid(strA(i), Len(strKategori) + 1) 'カテゴリを削る
'strA(i) = Replace(strA(i), strKategori, "") 'カテゴリを削る
Else '直前のカテゴリと不一致なら
strPreKategori = strKategori '直前のカテゴリとして値保持
End If
Next
strWk = Join(strA, ",") '処理後の配列をカンマ区切りの文字列に戻す
Cells(aa, 2).Value = strWk '結果格納
MUSI:
Next
Erase strA
End Sub
'与えられた文字列の先頭のアルファベットを取得する
Function fncGetKategori(ByVal strTarget As String) As String
'変数宣言
Dim i As Integer
Dim strRet As String
'初期化
fncGetKategori = ""
strRet = ""
'文字列の長さ分ループ
For i = 1 To Len(strTarget)
'取得した1文字を大文字化したものが
Select Case StrConv(Mid(strTarget, i, 1), vbUpperCase)
Case "A" To "Z" 'A〜Zなら
'何もしない
Case Else 'それ以外なら
strRet = Left(strTarget, i - 1) 'そこまでの文字を取得し抜ける
Exit For
End Select
Next
'結果をセット
fncGetKategori = strRet
End Function
〜〜〜〜ここまで〜〜〜〜
ramrunさんのリンク先見てみました、って確かに似ている、 というか同じデータですかね？ （ご近所PG）
おはようございます。
私なら、こうですかね汗
v(=∩_∩=)v
（SoulMan）
Sub テスト()
Dim MyA As Variant, MyAry() As String, MyStr() As String
Dim MyItemA As String, MyItemB As String, MyItemC As String, MyKey As String
Dim i As Long, j As Long, k As Long
Dim MyTbl As Range
With Worksheets("Sheet1")
'データ範囲の取得
Set MyTbl = .Range("A1", .Range("A65536").End(xlUp))
'データがなかったら変数をクリアにして中止
If Application.WorksheetFunction.CountA(MyTbl) < 1 Then
Set MyTbl = Nothing
Exit Sub
End If
'配列の取得
MyA = MyTbl.Value
'配列を用意
ReDim MyAry(1 To UBound(MyA, 1), 1 To 1)
'配列の上限までループ
For i = LBound(MyA, 1) To UBound(MyA, 1)
'スピリットで配列化
MyStr() = Split(MyA(i, 1), ",")
'MyStrの上限までループ
For j = LBound(MyStr, 1) To UBound(MyStr, 1)
'ItemAの初期化
MyItemA = Empty
'ItemCの初期化
MyItemC = Empty
'半角に変換
MyStr(j) = StrConv(MyStr(j), vbNarrow)
'要素の文字分ループ
For k = 1 To Len(MyStr(j))
'キーの取得を取得しながらItemAとItemCに分類する
MyKey = Mid(MyStr(j), k, 1)
'英語だったらItemAに代入それ以外はItemCに代入
If Asc(MyKey) >= 65 And Asc(MyKey) <= 90 Then
MyItemA = MyItemA & MyKey
Else
MyItemC = MyItemC & MyKey
End If
Next
'同じItemじゃなかったらそのまま追加
If MyItemB <> MyItemA Then
MyAry(i, 1) = MyAry(i, 1) & MyStr(j) & ","
'同じItem場合は、Keyを除いたItemCを追加
Else
MyAry(i, 1) = MyAry(i, 1) & MyItemC & ","
End If
'ItemBの更新
MyItemB = MyItemA
Next
'最後の「,」を加工して配列に追加
MyAry(i, 1) = Left(MyAry(i, 1), Len(MyAry(i, 1)) - 1)
'ItemBの初期化
MyItemB = Empty
Next
'抽出先をクリアーにして出力
.Columns(2).Cells.ClearContents
.Range("B1").Resize(UBound(MyA, 1)).Value = MyAry
End With
'配列及び変数の初期化
Set MyTbl = Nothing
Erase MyA, MyAry, MyStr
End Sub
少し、ご近所PGさんと答えが違う様ですが、どうかなぁ？？？
失礼しました。サンプルデータを掲示板からコピーしてそのまま使っていたので
二行目の先頭に空白が入っていました。空白を削除してから実行しましたら、
ご近所PGさんと同じ結果となりました。失礼しました。m(__)m
変換前
A1,A3-5,A10
A11-20,A22,B1-5
変換後
A1,3-5,10
A11-20,22,B1-5
変換前
AB1,AB3-5,AB10
A11-20,A22,BB1-5,A23-25
変換後
AB1,3-5,10
A11-20,22,BB1-5,A23-25
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.