[[20041008161833]] 『VBA:違うアルファベットは残す』(いまちゃん) >>BOT

[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]

 

『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)

毎回見直してるはずなのですが、いつも説明がわかりずらく申し訳ないです。
ご提示いただいた方法で一度がんばってみます。
わからない時はまたよろしくお願いしますm(_ _)m(いまちゃん)


 なんだか昔、似たようなのがあったきがしたので探してみました。
 結局↓も解決したのかしないのか(汗)...
 (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.