★★300PT質問

Question

aiomock

269

267もっと見る

300pt

コンピュータインターネット

★★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

※ 有料アンケート・ポイント付き質問機能は2023年2月28日に終了しました。

No.1

Mook13143932009/01/21 14:47:06

100pt

半角0.5文字、全角１文字という計算だと思いますが、それで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

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

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

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

Sub makeDataG()

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

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

2009/01/22 11:47:28

No.3

SALINGER34549692009/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

'連続した空白を空白１つにする関数
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

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

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

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

2009/01/22 14:23:05

SALINGER 2009/01/21 11:42:58

リンク先の例２の結果と４の処理が合ってないようだけど
ku__ra__ge 2009/01/21 12:50:10

＞作成されたあああいいいううう　は間に入れた半角スペースを入れて全部で１０文字になります。
とありますが、"あああいいいううう"は11文字ですよね？
これはどういう意味でしょう？
aiomock 2009/01/21 12:50:33

SALINGER さん

真に申し訳ありません。

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

★★２番の

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

本当に申し訳ありません。。
aiomock 2009/01/21 12:53:02

ku__ra__ge さん

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

こちらは　

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

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

説明不足で申し訳ありません。
aiomock 2009/01/21 12:54:12

ku__ra__ge さん

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

説明不足で申し訳ありません。
ku__ra__ge 2009/01/21 13:07:06

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

すいません。もうひとつ質問です。
「追加文字７～８は【】で囲まない」とありますが、そうであれば例２は
さささ【せせ】【そそ】ししし【た】すすすちつつ
になるのではないでしょうか？
SALINGER 2009/01/21 14:37:59

「追加文字７～８は【】で囲まない」ということは
例１のきききを入れても３０文字以内になりますよね。
それと、追加文字７～８の前には空白は入りますか？
aiomock 2009/01/21 15:48:55

ku__ra__ge さん

申し訳ありません。

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

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

なります。

私の間違いです。

変更させて頂きました。
aiomock 2009/01/21 15:53:13

SALINGER さん

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

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

お手数をおかけしますがよろしくお願いいたします。
SALINGER 2009/01/21 16:30:24

あああ【えええ】いいい【おおお】【かかか】うううききき
これで文字が27文字。スペースが6個で3文字で30文字になりませんか？
aiomock 2009/01/21 17:44:40

SALINGER さん

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

30文字に収まります。

申し訳ありません。
SALINGER 2009/01/21 18:53:27

補足。タイトル行とかがあって、２行目からデータの場合は、最初の方の
For i = 1 To lastRow
をi=2とかにしてください。
Mook 2009/01/21 20:14:52

あらら、４の仕様が漏れていましたね。
後は【】を使用しないのですか。

失礼しました。
Mook 2009/01/22 13:04:25

こちらでは動作確認済みですが

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

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

余計なお世話だとは思いますが、データはすべて全角文字という想定でしょうか。
であれば、SALINGER さんので問題ないですが、VBAで Len関数や LenB関数は今回の
ような半角、全角の長さを返してくれません。
SALINGER 2009/01/22 13:31:32

私の場合は、全て全角を想定しているというわけではなく、
単語の間の半角スペースのみを0.5文字とカウントするという解釈です。
aiomock 2009/01/22 14:29:47

Mook　さん

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

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

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

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

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

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

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

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

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

リクエスト送信済

回答リクエストを送信したユーザーはいません

SALINGER · Accepted Answer · 2009-01-21T18:19:15+09:00

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

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

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

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

'連続した空白を空白１つにする関数
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

SALINGER · Accepted Answer · 2009-01-21T18:19:15+09:00

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

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

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

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

'連続した空白を空白１つにする関数
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

★★300PT質問

ベストアンサー

SALINGER34549692009/01/21 18:19:15

その他の回答（2件）

Mook13143932009/01/21 14:47:06

SALINGER34549692009/01/21 18:19:15ここでベストアンサー

SALINGER34549692009/01/22 13:18:42

コメント（16件)

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