[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『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.