[[20040415165539]] 『VBA:文字列の分割&まとめる』(わからず) >>BOT

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

 

『VBA:文字列の分割&まとめる』(わからず)

仕事でいきずまってしまいました。どなたか良いご回答お願いします。

<したいこと>

 A	B
 1	A1-3,5,AB1-5
 2	R1-5,7,9,C5,FL1-5
 ・	・
 ・	・
 ・	・

とゆーよーなデータがずらっとありこのデータを

 A	B
 1	A1-3,5
 1.01	AB1-5
 2	R1-5,7,9
 2.01	C5
 2.02	FL1-5

となるように作成したいのですが、現在のコードでは

 A	B
 1	A1-3,5
 1.01	A1-5
 2	R1-5,7,9
 2.01	R5
 2.02	R1-5

と表示されてしまいます。コードをのせますので、良いアドバイスをお願いします。
※B列のデータはもっと長いのもあれば、短いのもありとさまざまです。

    Range("A2").Select
 Do While ActiveCell <> ""
    Selection.Offset(0, 1).Select
    roke = ActiveCell.Value
    Nagasa = Len(roke)
    Mijissou = "": MijissouL = "": MijissouR = ""
 For i = 2 To Nagasa
    If Val(Right(Left(roke, i), 1)) <> 0 Then Exit For
    Next
    Kategori = Left(roke, i - 1)
    If Left(roke, 1) = "<" Then _
    Mijissou = "<": MijissouL = "<": MijissouR = ">"
    If Nagasa >= 40 Then
    Selection.Offset(0, -1).Select
    Koumoku = ActiveCell.Value
    Koumoku = Koumoku + 0.01
    Selection.Offset(1, 0).Select
    ActiveWindow.SmallScroll Down:=1    '行の追加
    Selection.EntireRow.Insert          '行の追加
    ActiveCell.Value = Koumoku          '項目の追加(例:53.1)
 For i = 0 To 37
    A = Left(roke, 38 - i)
    B = Right(A, 1)
    If B = "," Then Exit For
    Next
    Selection.Offset(-1, 1).Select
    If Left(Left(roke, 38 - i - 1), 1) = "<" Then MijissouL = ""
    If Right(Left(roke, 38 - i - 1), 1) = ">" Then MijissouR = ""
    ActiveCell.Value = MijissouL & Left(roke, 38 - i - 1) & MijissouR
    roke = Right(roke, Nagasa - 38 + i)
    Selection.Offset(1, 0).Select
    ActiveCell.Value = Kategori & roke
    Selection.Offset(-1, 0).Select
    End If
    Selection.Offset(1, -1).Select
    Loop

ご教授よろしくお願いします。


 見づらかったので、勝手に修正〜

 (ramrun)


 上のコードで上のデータですと、わからずさんがいうような
 結果になりませんね。
 コードを読んでみても、そういう結果以前にいろいろあるんですけど
 それは置いといて。

 とりあえずMijissouの扱いが不明ですが、
 極力、わからずさんのコードを残す形で修正してみました。
 (ramrun)

 Sub macro()
    Range("A2").Select

 Do While ActiveCell <> ""
    Selection.Offset(0, 1).Select
    roke = ActiveCell.Value
    Nagasa = Len(roke)
    MijissouL = 0: MijissouR = 0

    For i = 2 To Nagasa
        If Val(Right(Left(roke, i), 1)) <> 0 Then Exit For
    Next

    Kategori = Left(roke, i - 1)

    For i = 1 To Len(roke)
        If Mid(roke, i, 1) = "," Then
            exec = True
            Exit For
        Else
            exec = False
        End If
    Next

    If exec Then
        Selection.Offset(0, -1).Select
        Koumoku = ActiveCell.Value
        Koumoku = Koumoku + 0.01
        Selection.Offset(1, 0).Select
        ActiveWindow.SmallScroll Down:=1
        Selection.EntireRow.Insert
        ActiveCell.Value = Koumoku

        For i = 1 To Len(roke)
            A = Left(roke, i)
            B = Right(A, 1)
            If B = "," Then
                If Not IsNumeric(Mid(roke, i + 1, 1)) Then
                    Exit For
                End If
            ElseIf i = Len(roke) Then
                Exit For
            End If
        Next

        Selection.Offset(-1, 1).Select

        If Left(roke, 1) = "<" Then MijissouL = 1
        If Right(Left(roke, i - 1), 1) = ">" Then MijissouR = 1

        strcnt = i - 1 - MijissouL
        ActiveCell.Value = Right(Left(roke, strcnt), strcnt - MijissouR)

        roke = Right(roke, Nagasa - i)
        Selection.Offset(1, 0).Select

        ActiveCell.Value = roke

        Selection.Offset(-1, 0).Select
    End If

    Selection.Offset(1, -1).Select
 Loop

 End Sub

ramrunさん ありがとうございます。さっそくためさせていただきましたが
roke = Right(roke, Nagasa - i) で”プロシージャの呼び出し、または引数が不正です”
とのエラーがでてしまいます。お助けお願いしますm(_ _)m
(わからず)

 お〜、師匠に先越されてしまったで。

 わたしゃ他人様のコードを読みとる理解力も根気もおまへんのんで、弥太郎流のコード
 を作ってみましたわ。
 A1から下へデータが並んどって、E,F列に結果をアウトプットする仕様になっとります
 さかい、必要に応じてご自分の適用範囲へコードを書き換えてくだはい。
    ほな...(弥太郎)
 '---------------------------
 Sub kubn()
    Dim i As Integer, t As Integer, n As Integer, y As Integer
    Dim maxrow As Long
    Dim grup() As Variant

    For i = 1 To Range("a65536").End(xlUp).Row
        t = 0
        ReDim Preserve grup(t)
        f = Split(Cells(i, 2), ",", -1)
        grup(t) = f(0)
        For n = 1 To UBound(f)
            ReDim Preserve grup(t)
            If IsNumeric(f(n)) Then
                grup(t) = grup(t) & "," & f(n)
            Else
                t = t + 1
                ReDim Preserve grup(t)
                grup(t) = f(n)
            End If
        Next n
        maxrow = Range("e65536").End(xlUp).Row + 1
        For y = 0 To UBound(grup)
             If y = 0 Then
                If maxrow = 2 Then
                    maxrow = maxrow - 1
                End If
                Cells(maxrow + y, 5) = "'" & i
            Else
                Cells(maxrow + y, 5) = "'" & i & "." & "0" & y
            End If
                Cells(maxrow + y, 6) = grup(y)
        Next y
    Next i

 End Sub

弥太郎さん ありがとうございます。早速ためさせてもらったのですが、
FL9001-9002,9101,FB3502-3504,4001,4101-4102,4502-4503,4801-4802,4901-4906
とゆーデータで試したところ、結果が

 1      FL9001-9002,9101
 1.01   FB3502-3504,4101
 1.02   4101-4102
 1.03   4502-4503
 1.04   4801-4802
 1.05   4901-4906

とゆー結果になります。
1.02以降にも頭にFBとつけたいのですが・・・ご教授お願いしますm(_ _)m
後、ここに書き込みをする際プレビューを押すと、表示が書き込みと変わって
文字が大きくなったり、しますがどうすればよいのですか?
(わからず)


 私のほうはexecの条件が適当すぎたみたいですね。

 お。
 kategoriってそのためにあったんですか。
 それで mijissou の扱いは?

 弥太郎さんのコードでは

 Cells(maxrow + y, 6) = grup(y)

 がデータの出力ですから、そこにご自分で考えられた

 For i = 2 To Nagasa
     If Val(Right(Left(roke, i), 1)) <> 0 Then Exit For
 Next
 Kategori = Left(roke, i - 1)

 を組み込んでみては?
 (ramrun)

mijissouはその後のコードをみても使用していなかったので、削除したいと思います。

>がデータの出力ですから、そこにご自分で考えられた

申し訳ないです・・・他の人が組んだものを修正させられているので・・・
いまいち理解ができていないです。教えていただけないでしょうか?m(_ _)m
(わからず)


 >他の人が組んだものを修正させられている

 冷たいようですが、そんなことは私には関係ないことです。
 あなた自身が自分でやる気があるのかどうかです。

 とりあえず
 Cells(maxrow + y, 6) = grup(y)

 のところを↓のようにしてみてください。
 Kategoriのコードを組み込んだだけなので、
 条件を見直さなければいけないかもしれません。
 (ramrun)

 For n = 2 To Len(grup(y))
    If Val(Right(Left(grup(y), n), 1)) <> 0 Then Exit For
 Next
 If IsNumeric(Left(grup(y), 1)) Then
    grup(y) = kategori & grup(y)
 Else
    kategori = Left(grup(y), n - 1)
 End If
 Cells(maxrow + y, 6) = grup(y)

ご回答ありがとうございました。
ramrunさん弥太郎さんに教えていただいたコードを活用させていただきます。
(わからず)

 ふがいない弟子の尻ぬぐいご苦労はんです。(笑)
 最初に貰うた情報には4000-4001等数値同士がハイフンで繋がってるなんぞおまへん
 でしたもんで・・・、いちゃもんは(わからず)さんの方へどうぞ。

 今申しました通り4000-4001にも英語をつけて拾うように書き換えときますた。
    ほんなら...(弥太郎)
 '-------------------------
 Sub kubn()
    Dim i As Integer, t As Integer, n As Integer, y As Integer
    Dim maxrow As Long
    Dim grup() As Variant

    For i = 1 To Range("a65536").End(xlUp).Row
        t = 0
        ReDim Preserve grup(t)
        f = Split(Cells(i, 2), ",", -1)
        grup(t) = f(0)
        For n = 1 To UBound(f)
            ReDim Preserve grup(t)

            If IsNumeric(f(n)) Then
                grup(t) = grup(t) & "," & f(n)
            Else
                If Not IsError(Split(f(n), "-")) And IsNumeric(Left(f(n), 1)) Then
                    t = t + 1
                    ReDim Preserve grup(t)
                    grup(t) = get_strg(grup, t) & f(n)
                Else
                    t = t + 1
                    ReDim Preserve grup(t)
                    grup(t) = f(n)
                End If
            End If
        Next n
        maxrow = Range("e65536").End(xlUp).Row + 1
        For y = 0 To UBound(grup)
             If y = 0 Then
                If maxrow = 2 Then
                    maxrow = maxrow - 1
                End If
                Cells(maxrow + y, 5) = "'" & i
            Else
                Cells(maxrow + y, 5) = "'" & i & "." & "0" & y
            End If
                Cells(maxrow + y, 6) = grup(y)
        Next y
    Next i

 End Sub
 '-----------------------------------
 Function get_strg(ByVal grup As Variant, ByVal t As Integer) As String
    Dim i As Integer
    For i = 1 To 2
        If Not IsNumeric(Mid(grup(t - 1), i, 1)) Then
            get_strg = get_strg & Mid(grup(t - 1), i, 1)
        Else
            Exit Function
        End If
    Next i
 End Function


弥太郎さん ご教授いただいたコードを活用させていただいてますが、
A B
1 A201
2 Q1201-1203,1403,2603,4301,4702,4705
3 Q1201-1203,1403,2603,4301,4702,4705
4 Q2601,4504,4506,4601-4603,4605-4606,4701,4703-4704,4706-4707,4801-4802
とゆーデータの場合、出力される結果が
E F
4 Q2601,4504,4506
4.01 Q4601-4603
4.02 Q4605-4606,4701
4.03 Q4703-4704
4.04 Q4706-4707
4.05 Q4801-4802
と表示され、1〜3は上書きされてしまいます。
1〜3も表示させるやり方を教えてくださいm(_ _)m
(わからず)

 (わからず)さん、遅うなってごめんなはれや。
 例によってケンショウブソクですわ、はい。(汗)
 If maxrow=2 Thenを If Cells(1,5)="" Then に変えておくんなはれ。
 これでいけるとおもいまっせ。タブン・・・。
 あかんかったらまたカキコしとってくだはい。アスの夜になります。
   ほな...(弥太郎)

弥太郎さん ありがとうございます。できましたm(_ _)m
またわからない事ありましたらご教授よろしくお願いします。
(わからず)

またまた不明点がでました(;_;)申し訳ないです。
A B
1 TP3205-3206,4502-4503
2
3
4
5 TP3205-3206,4502-4503
とB列に空きがある場合は出力結果もA列の出力のみでB列は空けておくことはできないでしょうか?

現在の出力結果は
A B
1 TP3205-3206
1.01 TP4502-4503
2 TP3205-3206
3 TP3205-3206
4 TP3205-3206
5 TP3205-3206
5.01 TP4502-4503
となります。
A B
1 TP3205-3206
1.01 TP4502-4503
2
3
4
5 TP3205-3206
5.01 TP4502-4503
と出力させれるようにしたいですm(_ _)m
(わからず)


 ちょっと、わからず屋はん。
 そう言う例示は最初からいうてくれまへんか?
 でないと、またコードをいじらなあきまへんさかいなぁ。
 はっきり言うて二度手間、三度手間になりまんねんで、えぇ。
 が、そこんとこが(わからず)のHNを名乗る所以なんでっしゃろけどなぁ。(笑)

  余談はさておいて
 下のコードに書き換えてくだはい。
  ほな...次は何が出てくるんやろ(弥太郎)
 '---------------------------------
 Sub kubn()
    Dim i As Integer, t As Integer, n As Integer, y As Integer
    Dim maxrow As Long
    Dim grup() As Variant

    For i = 1 To Range("a65536").End(xlUp).Row
        flag = False
        t = 0
        ReDim Preserve grup(t)
        If Cells(i, 2) <> "" Then

        f = Split(Cells(i, 2), ",", -1)
        grup(t) = f(0)
        For n = 1 To UBound(f)
            ReDim Preserve grup(t)

            If IsNumeric(f(n)) Then
                grup(t) = grup(t) & "," & f(n)
            Else
                If Not IsError(Split(f(n), "-")) And IsNumeric(Left(f(n), 1)) Then
                    t = t + 1
                    ReDim Preserve grup(t)
                    grup(t) = get_strg(grup, t) & f(n)
                Else
                    t = t + 1
                    ReDim Preserve grup(t)
                    grup(t) = f(n)
                End If
            End If
        Next n
        Else
            flag = True
            Cells(Range("e65536").End(xlUp).Row + 1, 5) = "'" & Cells(i, 1)
        End If
        If flag = False Then
        maxrow = Range("e65536").End(xlUp).Row + 1
        For y = 0 To UBound(grup)
             If y = 0 Then
                If Cells(1, 5) = "" Then
                    maxrow = maxrow - 1
                End If
                Cells(maxrow + y, 5) = "'" & i
            Else
                Cells(maxrow + y, 5) = "'" & i & "." & "0" & y
            End If
                Cells(maxrow + y, 6) = grup(y)
        Next y
        End If
    Next i

 End Sub

 '-----------------------------------
 Function get_strg(ByVal grup As Variant, ByVal t As Integer) As String
    Dim i As Integer
    For i = 1 To 2
        If Not IsNumeric(Mid(grup(t - 1), i, 1)) Then
            get_strg = get_strg & Mid(grup(t - 1), i, 1)
        Else
            Exit Function
        End If
    Next i
 End Function

弥太郎さん 出来の悪い私のためにご回答いただきありがとうございます。
さっそく使わせていただきました・・・申し訳ないです。
たしかに空白行はでなくなったのですが・・・
A B
1 TP3205-3206,4502-4503
2
3
4
5 TP3205-3206,4502-4503
とゆーデータで実行したところ、
A B
1 TP3205-3206
1.01 TP4502-4503
空白
空白
空白
5 TP3205-3206
5.01 TP4502-4503
とゆーデータになり、A列の数字が表示されません(;_;)
嫌気をささずにご回答よろしくお願いしますm(_ _)m
(わからず)

 >嫌気をささずにご回答よろしくお願いします
 別に嫌気が差しとるわけやおまへんでぇ、えぇ。
 これは、はい、私のミスショットですさかいナ。喜んで修正させて貰いますワ。
 お互いミスショットの連発で、まぁ、イーブンっちゅうとこでんな。(笑)
 長うなるんで上のコードを差し替えときました。
 試してみておくんなはれ。
   ほな...(弥太郎)

弥太郎さん ご回答ありがとうございます。描いた通りの動作をさせる事できており、
非常に感謝しております。もうひとつご教授いただきたい事があるのですが、

A B
1 A1,3,5,10-13,B1,3,5,10-3

とデータがある場合、

A B
1 A1,A3,A5,A10,A11,A12,A13,B1,B3,B5,B10,B11,B12,B13
と出力させるようにしたいのですが・・・
ご回答よろしくお願いしますm(_ _)m


 あのねえ(わからず)さん。
 申し訳おまへんけど
http://ryusendo.no-ip.com/cgi-bin/fswiki/wiki.cgi?page=%CC%EF%C2%C0%CF%BA%A4%CE%C9%F4%B2%B0
 に弥太郎の部屋ッちゅうんがありますさかいナ、そこへあらゆるデータを書き込んで
 それをどうしたいんかを書いてくれしまへんか?
 現状ではなんやら規則性がのうなってきとるみたいなんで、また新しい問題が発生
 しかねまへんやろ?
 せやさかい、あそこやったらどんなに長うなってもかめしまへんから洗いざらいの
 データパターンを書き込んでくだみてはい。編集ででけますさかいナ。
 念のために申し上げときますけどわたしゃ至って優しいにんげんですさかい、身構える
 必要はおまへんでぇ。(笑)
   ほな...(弥太郎)


コメント返信:

[ 一覧(最新更新順) ]


YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki. Modified by kazu.