人力検索はてな
モバイル版を表示しています。PC版はこちら
i-mobile

★★300PT質問

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

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

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

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

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

●質問者: aiomock
●カテゴリ:コンピュータ インターネット
✍キーワード:VBA エクセル プログラム 作成 文字列
○ 状態 :終了
└ 回答数 : 3/3件

▽最新の回答へ

1 ● Mook
●100ポイント

半角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
◎質問者からの返答

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

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

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

Sub makeDataG()

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

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


2 ● SALINGER
●100ポイント ベストアンサー

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

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

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


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
◎質問者からの返答

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

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

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

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


3 ● SALINGER
●100ポイント

大変失礼しました。

コード中の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
◎質問者からの返答

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

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

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

関連質問


●質問をもっと探す●



0.人力検索はてなトップ
8.このページを友達に紹介
9.このページの先頭へ
対応機種一覧
お問い合わせ
ヘルプ/お知らせ
ログイン
無料ユーザー登録
はてなトップ