★★300PT質問


エクセル(VBA)について質問です。

現在文字列を30文字以内に収めて自動で文字を作成するというプログラムを作成したいと考えております。

プログラムの流れですが以下のようになっております。

http://oskuni7.sakura.ne.jp/hatena//question13/question13.htm

時間があり、プログラムを組める方おりましたらお手数をおかけしますがよろしくお願いいたします。

回答の条件
  • 1人5回まで
  • 登録:2009/01/21 07:04:13
  • 終了:2009/01/22 14:30:45

ベストアンサー

id:SALINGER No.2

SALINGER回答回数3454ベストアンサー獲得回数9692009/01/21 18:19:15

ポイント100pt

疑問も解消されたので、作ってあったマクロを回答させていただきます。

私の場合は、直感的なコードで長くなってしまいました。

横幅が広くなったのでコピーする場合は、折り返しになってる部分を直してください。


Sub Macro1()
    Dim lastRow As Long
    Dim i As Long
    Dim j As Double
    Dim str As String
    Dim strC As String
    Dim strE As String
    Dim strF As String
    Dim strS As String
    Dim strT As String
    Dim strU As String
    Dim strV As String
    Dim strW As String
    Dim strX As String
    Dim strY As String
    Dim strZ As String
    
    lastRow = Cells(Rows.Count, 3).End(xlUp).Row
    For i = 1 To lastRow
        strC = Range("C" & i).Value
        strE = Range("E" & i).Value
        strF = Range("F" & i).Value
        If Range("S" & i).Value <> "" Then
            strS = "【" & Range("S" & i).Value & "】"
        Else
            strS = ""
        End If
        If Range("T" & i).Value <> "" Then
            strT = "【" & Range("T" & i).Value & "】"
        Else
            strT = ""
        End If
        If Range("U" & i).Value <> "" Then
            strU = "【" & Range("U" & i).Value & "】"
        Else
            strU = ""
        End If
        If Range("V" & i).Value <> "" Then
            strV = "【" & Range("V" & i).Value & "】"
        Else
            strV = ""
        End If
        If Range("W" & i).Value <> "" Then
            strW = "【" & Range("W" & i).Value & "】"
        Else
            strW = ""
        End If
        If Range("X" & i).Value <> "" Then
            strX = "【" & Range("X" & i).Value & "】"
        Else
            strX = ""
        End If
        If Range("Y" & i).Value <> "" Then
            strY = Range("Y" & i).Value
        Else
            strY = ""
        End If
        If Range("Z" & i).Value <> "" Then
            strZ = Range("Z" & i).Value
        Else
            strZ = ""
        End If
                
        str = strC & " " & strE & " " & strF
        j = Len(str) - 1
        If j <= 30 Then
            If strS <> "" Then
                j = j + Len(strS) + 0.5
            End If
            If j <= 30 Then
                If strT <> "" Then
                    j = j + Len(strT) + 0.5
                End If
                If j <= 30 Then
                    If strU <> "" Then
                        j = j + Len(strU) + 0.5
                    End If
                    If j <= 30 Then
                        If strV <> "" Then
                            j = j + Len(strV) + 0.5
                        End If
                        If j <= 30 Then
                            If strW <> "" Then
                                j = j + Len(strW) + 0.5
                            End If
                            If j <= 30 Then
                                If strX <> "" Then
                                    j = j + Len(strX) + 0.5
                                End If
                                If j <= 30 Then
                                    If strY <> "" Then
                                        j = j + Len(strY) + 0.5
                                    End If
                                    If j <= 30 Then
                                        If strZ <> "" Then
                                            j = j + Len(strZ) + 0.5
                                        End If
                                        If j <= 30 Then
                                            str = myRep(strC & " " & strS & " " & strT & " " & strU & " " & strV & " " & strW & " " & strX & " " & strE & " " & strF & " " & strY & " " & strZ)
                                        Else
                                            str = myRep(strC & " " & strS & " " & strT & " " & strU & " " & strV & " " & strW & " " & strX & " " & strE & " " & strF & " " & strY)
                                        End If
                                    Else
                                        str = myRep(strC & " " & strS & " " & strT & " " & strU & " " & strV & " " & strW & " " & strX & " " & strE & " " & strF)
                                    End If
                                Else
                                    str = myRep(strC & " " & strS & " " & strT & " " & strU & " " & strV & " " & strW & " " & strE & " " & strF)
                                End If
                            Else
                                str = myRep(strC & " " & strS & " " & strT & " " & strU & " " & strV & " " & strE & " " & strF)
                            End If
                        Else
                            str = myRep(strC & " " & strS & " " & strT & " " & strU & " " & strE & " " & strF)
                        End If
                    Else
                        str = myRep(strC & " " & strS & " " & strT & " " & strE & " " & strF)
                    End If
                Else
                    str = myRep(strC & " " & strS & " " & strE & " " & strF)
                End If
            End If
        End If
                
        Range("G" & i).Value = str
    Next
End Sub

'連続した空白を空白1つにする関数
Function myRep(str1 As String) As String
    Dim str2 As String
    Do
        str2 = Replace(str1, "  ", " ")
        If str1 = str2 Then
            Exit Do
        Else
            str1 = str2
        End If
    Loop
    myRep = str1
End Function
id:aiomock

ご回答ありがとうございます。

プログラム試してみましたが、追加文字3~6が、絶対文字2の前の所で反映されてしまいます。

後ろの部分で反映させるにはどうすればよろしいでしょうか。

お手数をおかけしますがお願いいたします。

2009/01/22 11:56:59

その他の回答(2件)

id:Mook No.1

Mook回答回数1312ベストアンサー獲得回数3912009/01/21 14:47:06

ポイント100pt

半角0.5文字、全角1文字という計算だと思いますが、それで30文字以内という実装です。

蛇足ですが、下の列はスペース込みで30.5文字になるので最後のデータは入らないようですが

その動作でよいでしょうか。

Const DELIM_A = "~"
Const DELIM_B = "^"
Const DELIM_C = ""

'-------------------------------------------------
Sub makeDataG()
'-------------------------------------------------
    Dim ln As Long
    Dim makeStr As String
    For ln = Range("C1").End(xlDown).Row To 2 Step -1
        makeStr = Cells(ln, "C").Value & DELIM_A & Cells(ln, "E").Value & DELIM_B & Cells(ln, "F").Value
    '--- ADD A
        makeStr = joinWord(makeStr, Cells(ln, "S").Value, DELIM_A)
        makeStr = joinWord(makeStr, Cells(ln, "T").Value, DELIM_A)
        
    '--- ADD B
        makeStr = joinWord(makeStr, Cells(ln, "U").Value, DELIM_B)
        makeStr = joinWord(makeStr, Cells(ln, "V").Value, DELIM_B)
        makeStr = joinWord(makeStr, Cells(ln, "W").Value, DELIM_B)
        makeStr = joinWord(makeStr, Cells(ln, "X").Value, DELIM_B)
        
    '--- ADD C
        makeStr = joinWord(makeStr, Cells(ln, "Y").Value, DELIM_C)
        makeStr = joinWord(makeStr, Cells(ln, "Z").Value, DELIM_C)
        
        makeStr = Replace(makeStr, DELIM_A, " ")
        
        Cells(ln, "G").Value = Replace(makeStr, DELIM_B, " ")
    Next
End Sub

'-------------------------------------------------
Function joinWord(baseWord As String, addWord As String, addChar As String)
'-------------------------------------------------
    If addWord = "" Then
        joinWord = baseWord
        Exit Function
    End If
    
    Dim tmpWord As String
    tmpWord = "【" & addWord & "】"
    
    If zhLen(baseWord) + zhLen(tmpWord) >= 60 Then
        joinWord = baseWord
        Exit Function
    End If
    
    Select Case addChar
    Case DELIM_A
        joinWord = Replace(baseWord, DELIM_A, " " & tmpWord & DELIM_A)
    Case DELIM_B
        joinWord = Replace(baseWord, DELIM_B, " " & tmpWord & DELIM_B)
    Case Else
        joinWord = baseWord & " " & tmpWord
    End Select
End Function

'-------------------------------------------------
Function zhLen(st As String) As Long
'-------------------------------------------------
    zhLen = LenB(StrConv(st, vbFromUnicode))
End Function
id:aiomock

ご回答ありがとうございます。

変数が定義されていません。

というエラーが出ています。

Sub makeDataG()

ここの部分がエラーとなっております。

お手数をおかけしますがよろしくお願いいたします。

2009/01/22 11:47:28
id:SALINGER No.2

SALINGER回答回数3454ベストアンサー獲得回数9692009/01/21 18:19:15ここでベストアンサー

ポイント100pt

疑問も解消されたので、作ってあったマクロを回答させていただきます。

私の場合は、直感的なコードで長くなってしまいました。

横幅が広くなったのでコピーする場合は、折り返しになってる部分を直してください。


Sub Macro1()
    Dim lastRow As Long
    Dim i As Long
    Dim j As Double
    Dim str As String
    Dim strC As String
    Dim strE As String
    Dim strF As String
    Dim strS As String
    Dim strT As String
    Dim strU As String
    Dim strV As String
    Dim strW As String
    Dim strX As String
    Dim strY As String
    Dim strZ As String
    
    lastRow = Cells(Rows.Count, 3).End(xlUp).Row
    For i = 1 To lastRow
        strC = Range("C" & i).Value
        strE = Range("E" & i).Value
        strF = Range("F" & i).Value
        If Range("S" & i).Value <> "" Then
            strS = "【" & Range("S" & i).Value & "】"
        Else
            strS = ""
        End If
        If Range("T" & i).Value <> "" Then
            strT = "【" & Range("T" & i).Value & "】"
        Else
            strT = ""
        End If
        If Range("U" & i).Value <> "" Then
            strU = "【" & Range("U" & i).Value & "】"
        Else
            strU = ""
        End If
        If Range("V" & i).Value <> "" Then
            strV = "【" & Range("V" & i).Value & "】"
        Else
            strV = ""
        End If
        If Range("W" & i).Value <> "" Then
            strW = "【" & Range("W" & i).Value & "】"
        Else
            strW = ""
        End If
        If Range("X" & i).Value <> "" Then
            strX = "【" & Range("X" & i).Value & "】"
        Else
            strX = ""
        End If
        If Range("Y" & i).Value <> "" Then
            strY = Range("Y" & i).Value
        Else
            strY = ""
        End If
        If Range("Z" & i).Value <> "" Then
            strZ = Range("Z" & i).Value
        Else
            strZ = ""
        End If
                
        str = strC & " " & strE & " " & strF
        j = Len(str) - 1
        If j <= 30 Then
            If strS <> "" Then
                j = j + Len(strS) + 0.5
            End If
            If j <= 30 Then
                If strT <> "" Then
                    j = j + Len(strT) + 0.5
                End If
                If j <= 30 Then
                    If strU <> "" Then
                        j = j + Len(strU) + 0.5
                    End If
                    If j <= 30 Then
                        If strV <> "" Then
                            j = j + Len(strV) + 0.5
                        End If
                        If j <= 30 Then
                            If strW <> "" Then
                                j = j + Len(strW) + 0.5
                            End If
                            If j <= 30 Then
                                If strX <> "" Then
                                    j = j + Len(strX) + 0.5
                                End If
                                If j <= 30 Then
                                    If strY <> "" Then
                                        j = j + Len(strY) + 0.5
                                    End If
                                    If j <= 30 Then
                                        If strZ <> "" Then
                                            j = j + Len(strZ) + 0.5
                                        End If
                                        If j <= 30 Then
                                            str = myRep(strC & " " & strS & " " & strT & " " & strU & " " & strV & " " & strW & " " & strX & " " & strE & " " & strF & " " & strY & " " & strZ)
                                        Else
                                            str = myRep(strC & " " & strS & " " & strT & " " & strU & " " & strV & " " & strW & " " & strX & " " & strE & " " & strF & " " & strY)
                                        End If
                                    Else
                                        str = myRep(strC & " " & strS & " " & strT & " " & strU & " " & strV & " " & strW & " " & strX & " " & strE & " " & strF)
                                    End If
                                Else
                                    str = myRep(strC & " " & strS & " " & strT & " " & strU & " " & strV & " " & strW & " " & strE & " " & strF)
                                End If
                            Else
                                str = myRep(strC & " " & strS & " " & strT & " " & strU & " " & strV & " " & strE & " " & strF)
                            End If
                        Else
                            str = myRep(strC & " " & strS & " " & strT & " " & strU & " " & strE & " " & strF)
                        End If
                    Else
                        str = myRep(strC & " " & strS & " " & strT & " " & strE & " " & strF)
                    End If
                Else
                    str = myRep(strC & " " & strS & " " & strE & " " & strF)
                End If
            End If
        End If
                
        Range("G" & i).Value = str
    Next
End Sub

'連続した空白を空白1つにする関数
Function myRep(str1 As String) As String
    Dim str2 As String
    Do
        str2 = Replace(str1, "  ", " ")
        If str1 = str2 Then
            Exit Do
        Else
            str1 = str2
        End If
    Loop
    myRep = str1
End Function
id:aiomock

ご回答ありがとうございます。

プログラム試してみましたが、追加文字3~6が、絶対文字2の前の所で反映されてしまいます。

後ろの部分で反映させるにはどうすればよろしいでしょうか。

お手数をおかけしますがお願いいたします。

2009/01/22 11:56:59
id:SALINGER No.3

SALINGER回答回数3454ベストアンサー獲得回数9692009/01/22 13:18:42

ポイント100pt

大変失礼しました。

コード中のstrEの位置が違いました。


Sub Macro1()
    Dim lastRow As Long
    Dim i As Long
    Dim j As Double
    Dim str As String
    Dim strC As String
    Dim strE As String
    Dim strF As String
    Dim strS As String
    Dim strT As String
    Dim strU As String
    Dim strV As String
    Dim strW As String
    Dim strX As String
    Dim strY As String
    Dim strZ As String
    
    lastRow = Cells(Rows.Count, 3).End(xlUp).Row
    For i = 1 To lastRow
        strC = Range("C" & i).Value
        strE = Range("E" & i).Value
        strF = Range("F" & i).Value
        If Range("S" & i).Value <> "" Then
            strS = "【" & Range("S" & i).Value & "】"
        Else
            strS = ""
        End If
        If Range("T" & i).Value <> "" Then
            strT = "【" & Range("T" & i).Value & "】"
        Else
            strT = ""
        End If
        If Range("U" & i).Value <> "" Then
            strU = "【" & Range("U" & i).Value & "】"
        Else
            strU = ""
        End If
        If Range("V" & i).Value <> "" Then
            strV = "【" & Range("V" & i).Value & "】"
        Else
            strV = ""
        End If
        If Range("W" & i).Value <> "" Then
            strW = "【" & Range("W" & i).Value & "】"
        Else
            strW = ""
        End If
        If Range("X" & i).Value <> "" Then
            strX = "【" & Range("X" & i).Value & "】"
        Else
            strX = ""
        End If
        If Range("Y" & i).Value <> "" Then
            strY = Range("Y" & i).Value
        Else
            strY = ""
        End If
        If Range("Z" & i).Value <> "" Then
            strZ = Range("Z" & i).Value
        Else
            strZ = ""
        End If
                
        str = strC & " " & strE & " " & strF
        j = Len(str) - 1
        If j <= 30 Then
            If strS <> "" Then
                j = j + Len(strS) + 0.5
            End If
            If j <= 30 Then
                If strT <> "" Then
                    j = j + Len(strT) + 0.5
                End If
                If j <= 30 Then
                    If strU <> "" Then
                        j = j + Len(strU) + 0.5
                    End If
                    If j <= 30 Then
                        If strV <> "" Then
                            j = j + Len(strV) + 0.5
                        End If
                        If j <= 30 Then
                            If strW <> "" Then
                                j = j + Len(strW) + 0.5
                            End If
                            If j <= 30 Then
                                If strX <> "" Then
                                    j = j + Len(strX) + 0.5
                                End If
                                If j <= 30 Then
                                    If strY <> "" Then
                                        j = j + Len(strY) + 0.5
                                    End If
                                    If j <= 30 Then
                                        If strZ <> "" Then
                                            j = j + Len(strZ) + 0.5
                                        End If
                                        If j <= 30 Then
                                            str = myRep(strC & " " & strS & " " & strT & " " & strE & " " & strU & " " & strV & " " & strW & " " & strX & " " & strF & " " & strY & " " & strZ)
                                        Else
                                            str = myRep(strC & " " & strS & " " & strT & " " & strE & " " & strU & " " & strV & " " & strW & " " & strX & " " & strF & " " & strY)
                                        End If
                                    Else
                                        str = myRep(strC & " " & strS & " " & strT & " " & strE & " " & strU & " " & strV & " " & strW & " " & strX & " " & strF)
                                    End If
                                Else
                                    str = myRep(strC & " " & strS & " " & strT & " " & strE & " " & strU & " " & strV & " " & strW & " " & strF)
                                End If
                            Else
                                str = myRep(strC & " " & strS & " " & strT & " " & strE & " " & strU & " " & strV & " " & strF)
                            End If
                        Else
                            str = myRep(strC & " " & strS & " " & strT & " " & strE & " " & strU & " " & strF)
                        End If
                    Else
                        str = myRep(strC & " " & strS & " " & strT & " " & strE & " " & strF)
                    End If
                Else
                    str = myRep(strC & " " & strS & " " & strE & " " & strF)
                End If
            End If
        End If
                
        Range("G" & i).Value = str
    Next
End Sub

'連続した空白を空白1つにする関数
Function myRep(str1 As String) As String
    Dim str2 As String
    Do
        str2 = Replace(str1, "  ", " ")
        If str1 = str2 Then
            Exit Do
        Else
            str1 = str2
        End If
    Loop
    myRep = str1
End Function
id:aiomock

ご回答ありがとうございます。

きれいに実行されました。

真にありがとうございます。

2009/01/22 14:23:05
  • id:SALINGER
    リンク先の例2の結果と4の処理が合ってないようだけど
  • id:ku__ra__ge
    >作成されたあああ いいい ううう は間に入れた半角スペースを入れて全部で10文字になります。
    とありますが、"あああ いいい ううう"は11文字ですよね?
    これはどういう意味でしょう?
  • id:aiomock
    SALINGER さん

    真に申し訳ありません。

    例1と例2の出力させる値を訂正いたしました。

    ★★2番の

    4番と5番の説明文が間違っていました。

    本当に申し訳ありません。。
  • id:aiomock
    ku__ra__ge さん

    ご連絡ありがとうございます。

    こちらは 

    あああ(3文字) (半角スペース 0.5文字)いいい(3文字) (半角スペース 0.5文字)ううう(3文字)

    と処理され合計で10文字になるということを示しています。

    説明不足で申し訳ありません。


  • id:aiomock
    ku__ra__ge さん

    半角スペースは0.5文字でカウントいたします。

    説明不足で申し訳ありません。
  • id:ku__ra__ge
    回答ありがとうございました。

    すいません。もうひとつ質問です。
    「追加文字7~8は【】で囲まない」とありますが、そうであれば例2は
    さささ 【せせ】【そそ】 ししし 【た】 すすす ち つつ
    になるのではないでしょうか?
  • id:SALINGER
    「追加文字7~8は【】で囲まない」ということは
    例1のきききを入れても30文字以内になりますよね。
    それと、追加文字7~8の前には空白は入りますか?
  • id:aiomock
    ku__ra__ge さん


    申し訳ありません。

    くらげさんにご指摘いただいたように

    さささ 【せせ】【そそ】 ししし 【た】 すすす ち つつ

    なります。

    私の間違いです。

    変更させて頂きました。
  • id:aiomock
    SALINGER さん

    追加文字7~8の間には半角スペース入ります。

    半角スペースを入れてきききを入れてみましたが30.5文字になり、これは30文字オーバーという結果になってしまいました。

    お手数をおかけしますがよろしくお願いいたします。
  • id:SALINGER
    あああ 【えええ】 いいい 【おおお】 【かかか】 ううう ききき
    これで文字が27文字。スペースが6個で3文字で30文字になりませんか?
  • id:aiomock
    SALINGER さん

    本当に申し訳ありません。。

    30文字に収まります。

    申し訳ありません。
  • id:SALINGER
    補足。タイトル行とかがあって、2行目からデータの場合は、最初の方の
    For i = 1 To lastRow
    をi=2とかにしてください。
  • id:Mook
    あらら、4の仕様が漏れていましたね。
    後は【 】を使用しないのですか。

    失礼しました。
  • id:Mook
    こちらでは動作確認済みですが

    ・標準モジュールに書いていますか?
    ・データは何行目から始まっていますか?

    ・最後の【】については未対応です。


    余計なお世話だとは思いますが、データはすべて全角文字という想定でしょうか。
    であれば、SALINGER さんので問題ないですが、VBAで Len関数や LenB関数は今回の
    ような半角、全角の長さを返してくれません。
  • id:SALINGER
    私の場合は、全て全角を想定しているというわけではなく、
    単語の間の半角スペースのみを0.5文字とカウントするという解釈です。
  • id:aiomock
    Mook さん

    標準モジュールに書いております。

    データは4行目からのスタートです。

    今回の想定ですが全角文字と半角文字二つを想定してのものになっております。

    説明不足で申し訳ありません。

    今回SALINGERさんの書いていただいたプログラムで起動いたしましたので一旦質問を終了させていただきます。

    Mookさん SALINGERさん にはいつもプログラムを書いていただき本当に感謝しております。

    今回もプログラムを書いていただき真にありがとうございます。

この質問への反応(ブックマークコメント)

「あの人に答えてほしい」「この質問はあの人が答えられそう」というときに、回答リクエストを送ってみてましょう。

これ以上回答リクエストを送信することはできません。制限について

絞り込み :
はてなココの「ともだち」を表示します。
回答リクエストを送信したユーザーはいません