'===========================
' フォルダ作成メイン処理
'===========================
Sub CreateFoldersWithSheetDate_AllColumns_BoldOnly()
Dim basePath As String
Dim sheetName As String
Dim dt As Date
Dim datePrefix As String
Dim yearPart As String, monthPart As String, dayPart As String
Dim tailText As String
Dim targetCols As Variant
Dim col As Variant
Dim lastRow As Long
Dim i As Long
Dim txt As String, namePart As String
Dim p1 As Long, p2 As Long
Dim folderName As String
basePath = "C:\Users\user\Desktop\LINE写真保存用\"
If Dir(basePath, vbDirectory) = "" Then
MsgBox "保存先フォルダが見つかりません: " & basePath, vbExclamation
Exit Sub
End If
sheetName = ActiveSheet.Name
'--- シート名が8桁（YYYYMMDD）の場合 ---
If Len(sheetName) = 8 And IsNumeric(sheetName) Then
yearPart = Left(sheetName, 4)
monthPart = Mid(sheetName, 5, 2)
dayPart = Right(sheetName, 2)
'--- シート名が4桁（MMDD）の場合 ---
ElseIf Len(sheetName) = 4 And IsNumeric(sheetName) Then
yearPart = Year(Date)
monthPart = Left(sheetName, 2)
dayPart = Right(sheetName, 2)
Else
MsgBox "シート名は「YYYYMMDD」または「MMDD」の形式にしてください。", vbExclamation
Exit Sub
End If
On Error Resume Next
dt = DateSerial(yearPart, monthPart, dayPart)
On Error GoTo 0
If dt = 0 Then
MsgBox "シート名の日付が正しくありません。", vbExclamation
Exit Sub
End If
datePrefix = Month(dt) & "月" & Day(dt) & "日"
' 対象列：A列(1), C列(3), E列(5)
targetCols = Array(1, 3, 5)
For Each col In targetCols
' 列ごとに 1 行目の文字を tailText として取得
tailText = Cells(1, col).Value
lastRow = Cells(Rows.Count, col).End(xlUp).Row
For i = 1 To lastRow
If Cells(i, col).DisplayFormat.Font.Bold = True Then
txt = Cells(i, col).Value
p1 = InStr(txt, "名前：")
p2 = InStr(txt, "顧客")
If p1 > 0 And p2 > p1 Then
namePart = Mid(txt, p1 + Len("名前："), p2 - (p1 + Len("名前：")))
namePart = Trim(namePart)
' ★ 名前の中の半角スペース・全角スペースをすべて削除
namePart = Replace(namePart, " ", "")
namePart = Replace(namePart, " ", "")
If namePart <> "" Then
' ★ （北恵）の前にスペースを入れない
' 日付と名前の間だけ全角スペースを1つ残す
folderName = datePrefix & " " & namePart & "様邸（北恵）" & tailText
folderName = CleanFileName(folderName)
If folderName <> "" Then
If Dir(basePath & folderName, vbDirectory) = "" Then
MkDir basePath & folderName
End If
End If
End If
End If
End If
Next i
Next col
MsgBox "LINE写真保存用フォルダへの作成が完了しました！"
End Sub
'===========================
' 禁止文字＋改行＋末尾の . / 半角スペース を除去
'===========================
Private Function CleanFileName(ByVal s As String) As String
Dim badChars As Variant
Dim c As Variant
' 改行をスペースに
s = Replace(s, Chr(10), " ")
s = Replace(s, Chr(13), " ")
' 禁止文字をスペースに置き換え
badChars = Array("\", "/", ":", "*", "?", """", "<", ">", "|")
For Each c In badChars
s = Replace(s, c, " ")
Next c
' 先頭と末尾の半角スペースを削除
s = Trim(s)
' 末尾が . または 半角スペース の場合は削る
Do While Len(s) > 0 And (Right$(s, 1) = "." Or Right$(s, 1) = " ")
s = Left$(s, Len(s) - 1)
Loop
CleanFileName = s
End Function
このコードの "様邸（北恵）"の部分を編集をしてほしい
（北恵）のカッコ内の文字を"顧客："の後ろの文字にして欲しい
例：顧客：ヤマダ→様邸（ヤマダ）
ユーザーはVBAコードの特定の部分を修正したいと考えている。
修正内容は、フォルダ名生成部分で、固定で「（北恵）」となっている部分を、特定のセルから取得した「顧客：」の後の文字列に置き換えたいとのこと。
コードの理解:
CreateFoldersWithSheetDate_AllColumns_BoldOnly サブルーチンがメインの処理。basePath に保存先ディレクトリが指定されている。datePrefix) を取得している。targetCols (A, C, E列) をループしている。tailText を取得している。txt) から「名前：」と「顧客」という文字列の位置を探し、namePart を抽出している。namePart から不要なスペースを削除している。folderName を datePrefix & " " & namePart & "様邸（北恵）" & tailText の形式で生成している。CleanFileName 関数でファイル名として不正な文字を除去している。修正箇所の特定:
folderName を生成している行: folderName = datePrefix & " " & namePart & "様邸（北恵）" & tailText"様邸（北恵）" の部分を、namePart の抽出時に取得した「顧客：」の後ろの文字列（例：「ヤマダ」）に置き換えたい。問題点の分析:
namePart は「名前：」と「顧客」の間にある文字列を抽出している。namePart の抽出条件に関わっている可能性がある。p1 = InStr(txt, "名前：") で「名前：」の位置を取得し、p2 = InStr(txt, "顧客") で「顧客」の位置を取得している。namePart = Mid(txt, p1 + Len("名前："), p2 - (p1 + Len("名前："))) で、「名前：」の直後から「顧客」の直前までの文字列を namePart として取得している。namePart は「名前：〇〇 顧客」のようなテキストの場合、「〇〇」の部分になる。namePart として取得することはできていない。修正方針の検討:
namePart の抽出範囲に含めるように p2 の取得方法を変更する。p2 = InStr(txt, "顧客：") のように、「顧客：」を検索する。namePart は「名前：〇〇 顧客：」までを取得してしまう。namePart から「顧客：」を取り除く処理が必要になる。p1 = InStr(txt, "名前：") や p2 = InStr(txt, "顧客") の使われ方から、現状は「名前：」と「顧客」の間にある文字列を namePart としている。namePart として「ヤマダ」を取得し、フォルダ名に「様邸（ヤマダ）」としたい。namePart は「〇〇」になっている。namePart の抽出ロジック自体を変更する必要がある。具体的な修正手順 (案1をベースに、よりユーザーの意図に沿うように調整):
namePart は「名前：」と「顧客」の間。namePart として取得したい。p1 を「名前：」ではなく、「顧客：」の開始位置として再定義する必要がある。あるいは、既存の namePart (「名前：」と「顧客」の間) を取得した後、さらに「顧客：」という文字列を探し、その後ろの文字列を抽出する。
再検討: ユーザーの例「顧客：ヤマダ→様邸（ヤマダ）」は、元のコードの namePart の抽出ロジックとは少し異なる。
namePart = Mid(txt, p1 + Len("名前："), p2 - (p1 + Len("名前：")))txt = "〇〇 名前：山田 顧客 △△" -> namePart = "山田 "txt = "〇〇 名前：山田 顧客：ヤマダ △△" -> namePart を「ヤマダ」にしたい。修正案:
namePart) を取得するロジックは一旦そのままにしておく。namePart を取得した後、さらに txt の中から「顧客：」を探し、その後ろの文字列を抽出する。namePart を使うか、あるいはエラー処理をする。コードの場所:
If p1 > 0 And p2 > p1 Then ' ここで namePart が取得されている
namePart = Mid(txt, p1 + Len("名前："), p2 - (p1 + Len("名前：")))
namePart = Trim(namePart)
' ★ 名前の中の半角スペース・全角スペースをすべて削除
namePart = Replace(namePart, " ", "")
namePart = Replace(namePart, " ", "")
' ここからが修正対象
' If namePart <> "" Then
' folderName = datePrefix & " " & namePart & "様邸（北恵）" & tailText
' folderName = CleanFileName(folderName)
' If folderName <> "" Then
' If Dir(basePath & folderName, vbDirectory) = "" Then
' MkDir basePath & folderName
' End If
' End If
' End If
具体的な修正ロジック:
namePart を取得する。txt の中から「顧客：」を探す。customerPos = InStr(txt, "顧客：")customerPos > p1)、namePart とする。newCustomerName = Mid(txt, customerPos + Len("顧客："))newCustomerName から、もし「顧客：」の後ろにさらに不要な文字列（例：「 △△」）があれば、それも除去する必要がある。p2 (「顧客」の位置) を使って namePart の長さを決めている。よりシンプルなアプローチ:
「名前：」と「顧客」の間ではなく、「顧客：」の後ろの文字列を直接取得する。
txt の中から「顧客：」を探す。namePart として使う。コードの改変:
' 元のコード
' p1 = InStr(txt, "名前：")
' p2 = InStr(txt, "顧客")
' If p1 > 0 And p2 > p1 Then
' namePart = Mid(txt, p1 + Len("名前："), p2 - (p1 + Len("名前：")))
' namePart = Trim(namePart)
' namePart = Replace(namePart, " ", "")
' namePart = Replace(namePart, " ", "")
' 修正案：
Dim customerNamePart As String
Dim customerColonPos As Long
' まず、「顧客：」の位置を探す
customerColonPos = InStr(txt, "顧客：")
If customerColonPos > 0 Then
' 「顧客：」が見つかった場合、その後の文字列を取得
' 取得する範囲は、"顧客：" の直後から、もし「名前：」が「顧客：」より後にあるならその手前まで、
' あるいは単に「顧客：」の後ろから最後まで、とする。
' ここで、元のコードの p1 (名前：の位置) と p2 (顧客の位置) をどう使うか？
' ユーザーの例「顧客：ヤマダ→様邸（ヤマダ）」は、txtが "名前：〇〇 顧客：ヤマダ △△" のような形式を想定しているか？
' それとも、txtが "顧客：ヤマダ △△" のような形式でも対応したいか？
' 一旦、元のコードのp1, p2のロジックを活かしつつ、
' 「顧客：」の後ろの文字列を抽出する方向で考える。
' ユーザーの例は「名前：」の後に「顧客：」が来ることを想定しているように見える。
' 取得したいのは「顧客：」の後の文字列。
' その文字列がどこまでか？
' 元のコードでは「顧客」という文字列を区切りとしていた。
' もし「顧客：ヤマダ △△」という形式なら、
' customerColonPos = InStr(txt, "顧客：")
' customerNamePart = Mid(txt, customerColonPos + Len("顧客："))
' この customerNamePart には "ヤマダ △△" が入る。
' この "△△" の部分をどう処理するか？
' 元のコードの p2 (「顧客」の位置) は、この「△△」の開始位置を特定するのに役立つかもしれない。
' 別の考え方:
' 「名前：」と「顧客」の位置を元に、
' 「顧客：」という文字列を探し、その後の部分を抽出する。
' もし「顧客：」が見つからなければ、元の `namePart` を使う、というフォールバックも考えられる。
' コードをシンプルにするために、
' ユーザーの例「顧客：ヤマダ→様邸（ヤマダ）」を素直に解釈する。
' これは、txtの中に「顧客：」という文字列があり、その直後の文字列をフォルダ名に使いたい、ということ。
' 元のコードの `p1` と `p2` は、太字のセル内のテキスト `txt` から「名前：」と「顧客」を探している。
' この `txt` の形式がどうなっているかによって、修正方法が変わる。
'仮定: txtは "〇〇 名前：山田 顧客：ヤマダ △△" のような形式である。
' ユーザーは「ヤマダ」の部分を使いたい。
' 元のコードでは、p1=名前：の位置, p2=顧客の位置。
' namePart = Mid(txt, p1 + Len("名前："), p2 - (p1 + Len("名前："))) -> "山田 " を取得。
' これではダメ。
' 修正方針：
' 1. 「顧客：」という文字列を `txt` の中で探す。
' 2. 見つかったら、その位置から後ろの文字列を取得する。
' 3. 取得した文字列の末尾に不要な文字（例：「 △△」）がある場合、それを除去する。
' 4. その結果を `namePart` として使う。
Dim customerColonPos As Long
Dim extractedName As String
' まず「顧客：」を探す
customerColonPos = InStr(txt, "顧客：")
If customerColonPos > 0 Then
' 「顧客：」が見つかった場合、その後の文字列を取得
extractedName = Mid(txt, customerColonPos + Len("顧客："))
' 取得した文字列から、もし「名前：」が「顧客：」より後にある場合、
' その「名前：」の手前までを抽出する、というロジックも考えられるが、
' ユーザーの例「顧客：ヤマダ→様邸（ヤマダ）」は、
' 「顧客：」の後ろがそのまま名前に対応する形式を想定しているように見える。
' ここで、元のコードの `p2` (「顧客」の位置) が使えそう。
' `p2` は「顧客」という文字列の開始位置。
' もし `txt` が "名前：〇〇 顧客 △△" の場合、 `p2` は「顧客」の開始位置。
' もし `txt` が "名前：〇〇 顧客：ヤマダ △△" の場合、`customerColonPos` は「顧客：」の開始位置。
' ユーザーの例は「顧客：ヤマダ」なので、`customerColonPos` を使うのが適切。
' 取得した `extractedName` には「ヤマダ △△」のような文字列が入る可能性がある。
' この「△△」の部分をどう処理するか？
' 元のコードでは `p2` を使って `namePart` の長さを決めていた。
' `p2 - (p1 + Len("名前："))`
' これは「名前：」から「顧客」までの長さ。
' もし「顧客：」の後ろに余計な文字列がある場合、
' その余計な文字列の開始位置を特定する必要がある。
' ユーザーの例「顧客：ヤマダ→様邸（ヤマダ）」に素直に従うと、
' 「顧客：」の後ろの文字列をそのまま使う。
' ただし、その文字列の末尾に不要なものがないか？
' 元のコードの `CleanFileName` 関数で処理されるので、
' ここでは一旦、`customerColonPos` の後ろから最後までを取得し、
' それを `namePart` とする。
' 修正後の `namePart` 抽出ロジック:
Dim customerColonPos As Long
Dim namePartCandidate As String
' まず「顧客：」を探す
customerColonPos = InStr(txt, "顧客：")
If customerColonPos > 0 Then
' 「顧客：」が見つかった場合、その後の文字列を取得
' 取得する範囲は、「顧客：」の直後から、もし「名前：」が「顧客：」より後にあるならその手前まで。
' しかし、ユーザーの例は「顧客：ヤマダ」なので、
' 「顧客：」の後ろから、もし "様邸" や "顧客" などの区切りがあればその手前まで、と考えるのが自然。
' 元のコードの `p2` は「顧客」の位置。
' `p1` は「名前：」の位置。
' `txt` の例: "〇〇 名前：山田 顧客：ヤマダ △△"
' `p1` は「名前：」の開始位置
' `customerColonPos` は「顧客：」の開始位置
' `p2` は「顧客」の開始位置 (もしあれば)
' ユーザーの要望「顧客：ヤマダ→様邸（ヤマダ）」を素直に解釈する。
' フォルダ名に使うのは「ヤマダ」の部分。
' これは `txt` から「顧客：」を探し、その後の文字列を `namePart` にしたい。
' `namePart` は、最終的に「様邸（）」の中に入るので、
' 「様邸」や「顧客」といった単語が後ろに来る可能性も考慮する。
' 修正案：
' 「顧客：」の後ろから、次の「名前：」や「顧客」のような区切り文字、
' あるいは単に末尾までを取得する。
' 元のコードの `p2` (「顧客」の位置) は、もし「顧客：」の後に「顧客」という単語が続く場合、
' その「顧客」の位置を指すことになる。
' `txt` の例: "〇〇 名前：山田 顧客：ヤマダ △△"
' `p1` = InStr(txt, "名前：")
' `customerColonPos` = InStr(txt, "顧客：")
' `p2` = InStr(txt, "顧客") ' これは「顧客：」とは別の「顧客」を探すことになる。
' ユーザーの例「顧客：ヤマダ→様邸（ヤマダ）」をそのまま実装する。
' `namePart` を「顧客：」の後ろの文字列にする。
' その文字列の末尾は、もし「名前：」や「顧客」といった単語があればその手前までとする。
' しかし、最もシンプルなのは「顧客：」の後ろから最後まで取得し、
' `CleanFileName` で不要な文字を除去すること。
' 修正ロジック：
Dim customerColonPos As Long
Dim namePartFromCustomer As String
' まず「顧客：」を探す
customerColonPos = InStr(txt, "顧客：")
If customerColonPos > 0 Then
' 「顧客：」が見つかった場合、その後の文字列を取得
namePartFromCustomer = Mid(txt, customerColonPos + Len("顧客："))
' ここで、もし `namePartFromCustomer` に「名前：」や「顧客」といった単語が
' 含まれている場合、その手前で区切る必要があるかもしれない。
' 例: "顧客：ヤマダ 名前：田中" -> "ヤマダ" だけを取りたい。
' 元のコードでは `p2` (「顧客」の位置) を使って区切っていた。
' `p2` は「顧客」という単語の位置。
' `customerColonPos` は「顧客：」という文字列の位置。
' もし `txt` が "名前：山田 顧客：ヤマダ △△" の場合:
' `p1` = InStr(txt, "名前：")
' `customerColonPos` = InStr(txt, "顧客：")
' `p2` = InStr(txt, "顧客") ' これは「顧客：」とは別の「顧客」を探すことになる。
' ユーザーの例は「顧客：ヤマダ」なので、`customerColonPos` を使うのが自然。
' `namePartFromCustomer` には「ヤマダ △△」が入る。
' この「△△」をどう処理するか？
' 元のコードの `p2` (「顧客」の位置) が、この「△△」の開始位置を特定するのに役立つか？
' もし `txt` が "名前：山田 顧客：ヤマダ △△" なら、`p2` は「顧客」の開始位置。
' `customerColonPos` は「顧客：」の開始位置。
' `p2` は `customerColonPos` よりも後ろにあるはず。
' `p2 - customerColonPos` は「：ヤマダ △△」の長さ。
' ユーザーの例「顧客：ヤマダ→様邸（ヤマダ）」を素直に実装する。
' `namePart` は「顧客：」の後ろの文字列。
' その文字列の末尾は、もし「名前：」や「顧客」のような区切りがあればその手前まで。
' `txt` の形式を想定: "〇〇 名前：山田 顧客：ヤマダ △△"
' `p1` = InStr(txt, "名前：")
' `customerColonPos` = InStr(txt, "顧客：")
' `p2` = InStr(txt, "顧客") ' これは「顧客：」とは別の「顧客」を探すことになる。
' 修正案：
' 1. 「顧客：」の位置 `customerColonPos` を探す。
' 2. もし見つかったら、`customerColonPos` の後ろから文字列を取得する。
' 3. その文字列の末尾を、もし `p2` (「顧客」の位置) が `customerColonPos` より後にあるなら、`p2` の手前までとする。
' そうでなければ、末尾までとする。
Dim customerColonPos As Long
Dim namePartFromCustomer As String
Dim endPos As Long
' まず「顧客：」を探す
customerColonPos = InStr(txt, "顧客：")
If customerColonPos > 0 Then
' 「顧客：」が見つかった場合
' 取得する文字列の開始位置は「顧客：」の直後
Dim startPos As Long
startPos = customerColonPos + Len("顧客：")
' 取得する文字列の終了位置を決定する
' もし「顧客」という単語が「顧客：」の後にある場合、その手前まで
Dim customerWordPos As Long
customerWordPos = InStr(startPos, txt, "顧客") ' startPosから検索
If customerWordPos > 0 Then
' 「顧客：」の後ろに「顧客」という単語がある場合、その手前まで
endPos = customerWordPos - 1
Else
' 「顧客」という単語がない場合、文字列の最後まで
endPos = Len(txt)
End If
' 抽出する文字列の長さを計算
Dim lenToExtract As Long
lenToExtract = endPos - startPos + 1
If lenToExtract > 0 Then
namePartFromCustomer = Mid(txt, startPos, lenToExtract)
namePartFromCustomer = Trim(namePartFromCustomer)
' namePartFromCustomer には「ヤマダ」のような文字列が入る
Else
' 抽出できる文字列がない場合
namePartFromCustomer = ""
End If
Else
' 「顧客：」が見つからなかった場合、元のロジックで `namePart` を取得する
' (これはユーザーの意図と少しずれるかもしれないが、フォールバックとして)
' ユーザーの例「顧客：ヤマダ→様邸（ヤマダ）」に素直に従うと、
' 「顧客：」が見つからない場合は、この処理はスキップするべきか？
' それとも、元の `namePart` を使うべきか？
' 元の `namePart` は「名前：」と「顧客」の間。
' ユーザーは「顧客：」の後ろを使いたいので、
' 「顧客：」が見つからない場合は、この新しいロジックは適用しない。
' その場合、元の `namePart` を使うか、あるいは処理をスキップするか。
' ユーザーの要望は「（北恵）のカッコ内の文字を"顧客："の後ろの文字にして欲しい」なので、
' 「顧客：」が見つからない場合は、この変更は適用されないと考えるのが自然。
' よって、`namePart` は空にするか、あるいは元のロジックをそのまま使う。
' ここは、`namePart` を一旦初期化し、新しいロジックで取得できなかったら空にする、という形が良いか。
namePartFromCustomer = "" ' 初期化
End If
' 取得した `namePartFromCustomer` を `namePart` として使う
If namePartFromCustomer <> "" Then
' ★ 名前の中の半角スペース・全角スペースをすべて削除
namePartFromCustomer = Replace(namePartFromCustomer, " ", "")
namePartFromCustomer = Replace(namePartFromCustomer, " ", "")
' ★ （北恵）の前にスペースを入れない
' 日付と名前の間だけ全角スペースを1つ残す
' folderName = datePrefix & " " & namePart & "様邸（北恵）" & tailText
' 修正：namePart を namePartFromCustomer に置き換える
folderName = datePrefix & " " & namePartFromCustomer & "様邸（北恵）" & tailText
folderName = CleanFileName(folderName)
If folderName <> "" Then
If Dir(basePath & folderName, vbDirectory) = "" Then
MkDir basePath & folderName
End If
End If
End If
End If ' If customerColonPos > 0 Then
Else
' 「名前：」と「顧客」の間から `namePart` を取得する元のロジック
' この場合、`namePart` は「名前：」と「顧客」の間になる。
' ユーザーの要望は「顧客：」の後ろなので、この元のロジックは使わない。
' したがって、この `Else` ブロックは不要になる。
' If p1 > 0 And p2 > p1 Then ... End If
End If
End If ' If p1 > 0 And p2 > p1 Then (元のコードのif文)
コードの整理と再構築: 元のコードの If p1 > 0 And p2 > p1 Then ブロック全体を、新しいロジックに置き換える。 新しいロジックでは、「顧客：」を探し、その後の文字列を namePart として使用する。
' 元のコードの該当部分
' p1 = InStr(txt, "名前：")
' p2 = InStr(txt, "顧客")
' If p1 > 0 And p2 > p1 Then
' namePart = Mid(txt, p1 + Len("名前："), p2 - (p1 + Len("名前：")))
' namePart = Trim(namePart)
' namePart = Replace(namePart, " ", "")
' namePart = Replace(namePart, " ", "")
' ' ... folderName 生成 ...
' End If
' 修正後のロジック
Dim customerColonPos As Long
Dim namePartToUse As String ' 最終的にフォルダ名に使う名前部分
Dim extractedName As String ' 「顧客：」から抽出した名前候補
' まず「顧客：」を探す
customerColonPos = InStr(txt, "顧客：")
If customerColonPos > 0 Then
' 「顧客：」が見つかった場合
Dim startPos As Long
startPos = customerColonPos + Len("顧客：")
' 抽出する文字列の終了位置を決定する
' もし「顧客」という単語が「顧客：」の後にある場合、その手前まで
Dim customerWordPos As Long
' startPos から検索することで、「顧客：」より前の「顧客」を誤って探さないようにする
customerWordPos = InStr(startPos, txt, "顧客")
Dim endPos As Long
If customerWordPos > 0 Then
' 「顧客：」の後ろに「顧客」という単語がある場合、その手前まで
endPos = customerWordPos - 1
Else
' 「顧客」という単語がない場合、文字列の最後まで
endPos = Len(txt)
End If
' 抽出する文字列の長さを計算
Dim lenToExtract As Long
lenToExtract = endPos - startPos + 1
If lenToExtract > 0 Then
extractedName = Mid(txt, startPos, lenToExtract)
extractedName = Trim(extractedName)
' extractedName には「ヤマダ」のような文字列が入る
Else
extractedName = "" ' 抽出できる文字列がない場合
End If
' 抽出した名前をフォルダ名に使用する
If extractedName <> "" Then
' ★ 名前の中の半角スペース・全角スペースをすべて削除
namePartToUse = Replace(extractedName, " ", "")
namePartToUse = Replace(namePartToUse, " ", "")
' ★ （北恵）の前にスペースを入れない
' 日付と名前の間だけ全角スペースを1つ残す
folderName = datePrefix & " " & namePartToUse & "様邸（北恵）" & tailText
folderName = CleanFileName(folderName)
If folderName <> "" Then
If Dir(basePath & folderName, vbDirectory) = "" Then
MkDir basePath & folderName
End If
End If
End If
Else
' 「顧客：」が見つからなかった場合、元のロジックで `namePart` を取得し、
' それを `namePartToUse` として使用する。
' 元のロジックは「名前：」と「顧客」の間を取得する。
' ユーザーの要望は「顧客：」の後ろなので、この `Else` ブロックは、
' 「顧客：」が見つからなかった場合のフォールバックとして、元のロジックを適用する。
Dim p1 As Long, p2 As Long
p1 = InStr(txt, "名前：")
p2 = InStr(txt, "顧客") ' ここで「顧客」という単語を探す
If p1 > 0 And p2 > p1 Then
' 「名前：」と「顧客」の間を取得
namePartToUse = Mid(txt, p1 + Len("名前："), p2 - (p1 + Len("名前：")))
namePartToUse = Trim(namePartToUse)
' namePartToUse には「山田」のような文字列が入る
' namePartToUse が空でない場合のみ処理
If namePartToUse <> "" Then
' ★ 名前の中の半角スペース・全角スペースをすべて削除
namePartToUse = Replace(namePartToUse, " ", "")
namePartToUse = Replace(namePartToUse, " ", "")
' ★ （北恵）の前にスペースを入れない
' 日付と名前の間だけ全角スペースを1つ残す
folderName = datePrefix & " " & namePartToUse & "様邸（北恵）" & tailText
folderName = CleanFileName(folderName)
If folderName <> "" Then
If Dir(basePath & folderName, vbDirectory) = "" Then
MkDir basePath & folderName
End If
End If
End If
End If
End If
さらにシンプルに: ユーザーの要望は「（北恵）のカッコ内の文字を"顧客："の後ろの文字にして欲しい」なので、 「顧客：」が見つからなかった場合は、元の「（北恵）」をそのまま使うのが最も自然。 つまり、namePartToUse を「顧客：」の後ろの文字列にする。 「顧客：」が見つからなかった場合は、namePartToUse は空にして、フォルダ名生成部分で If namePartToUse <> "" Then のようにチェックする。
' 修正後のロジック（よりシンプルに）
Dim customerColonPos As Long
Dim namePartFromCustomer As String ' 「顧客：」から抽出した名前
' まず「顧客：」を探す
customerColonPos = InStr(txt, "顧客：")
If customerColonPos > 0 Then
' 「顧客：」が見つかった場合
Dim startPos As Long
startPos = customerColonPos + Len("顧客：")
' 抽出する文字列の終了位置を決定する
' もし「顧客」という単語が「顧客：」の後にある場合、その手前まで
Dim customerWordPos As Long
customerWordPos = InStr(startPos, txt, "顧客")
Dim endPos As Long
If customerWordPos > 0 Then
endPos = customerWordPos - 1
Else
endPos = Len(txt)
End If
' 抽出する文字列の長さを計算
Dim lenToExtract As Long
lenToExtract = endPos - startPos + 1
If lenToExtract > 0 Then
namePartFromCustomer = Mid(txt, startPos, lenToExtract)
namePartFromCustomer = Trim(namePartFromCustomer)
' namePartFromCustomer には「ヤマダ」のような文字列が入る
Else
namePartFromCustomer = "" ' 抽出できる文字列がない場合
End If
End If
' namePartToUse を決定する
Dim namePartToUse As String
If namePartFromCustomer <> "" Then
' 「顧客：」から抽出できた場合、それを使用
namePartToUse = Replace(namePartFromCustomer, " ", "")
namePartToUse = Replace(namePartToUse, " ", "")
Else
' 「顧客：」が見つからなかった場合、元のロジックで取得した名前を使用する
' 元のロジックは「名前：」と「顧客」の間を取得する
Dim p1 As Long, p2 As Long
p1 = InStr(txt, "名前：")
p2 = InStr(txt, "顧客") ' ここで「顧客」という単語を探す
If p1 > 0 And p2 > p1 Then
' 「名前：」と「顧客」の間を取得
namePartToUse = Mid(txt, p1 + Len("名前："), p2 - (p1 + Len("名前：")))
namePartToUse = Trim(namePartToUse)
' namePartToUse には「山田」のような文字列が入る
If namePartToUse <> "" Then
namePartToUse = Replace(namePartToUse, " ", "")
namePartToUse = Replace(namePartToUse, " ", "")
End If
Else
' 「名前：」も「顧客」も見つからなかった場合、namePartToUse は空のまま
namePartToUse = ""
End If
End If
' フォルダ名の生成
If namePartToUse <> "" Then
' ★ （北恵）の前にスペースを入れない
' 日付と名前の間だけ全角スペースを1つ残す
folderName = datePrefix & " " & namePartToUse & "様邸（北恵）" & tailText
folderName = CleanFileName(folderName)
If folderName <> "" Then
If Dir(basePath & folderName, vbDirectory) = "" Then
MkDir basePath & folderName
End If
End If
End If
最終的なコードの構造: 元の If Cells(i, col).DisplayFormat.Font.Bold = True Then の中の、 txt = Cells(i, col).Value の後から、folderName = CleanFileName(folderName) の前までを置き換える。
If Cells(i, col).DisplayFormat.Font.Bold = True Then
txt = Cells(i, col).Value
Dim p1 As Long, p2 As Long
p1 = InStr(txt, "名前：")
p2 = InStr(txt, "顧客") ' 「顧客」という単語の位置
Dim customerColonPos As Long
customerColonPos = InStr(txt, "顧客：") ' 「顧客：」という文字列の位置
Dim namePartToUse As String ' 最終的にフォルダ名に使う名前部分
Dim extractedName As String ' 「顧客：」から抽出した名前候補
If customerColonPos > 0 Then
' 「顧客：」が見つかった場合、その後の文字列を優先的に使用する
Dim startPos As Long
startPos = customerColonPos + Len("顧客：")
' 抽出する文字列の終了位置を決定する
' もし「顧客」という単語が「顧客：」の後にある場合、その手前まで
Dim customerWordPos As Long
customerWordPos = InStr(startPos, txt, "顧客")
Dim endPos As Long
If customerWordPos > 0 Then
' 「顧客：」の後ろに「顧客」という単語がある場合、その手前まで
endPos = customerWordPos - 1
Else
' 「顧客」という単語がない場合、文字列の最後まで
endPos = Len(txt)
End If
' 抽出する文字列の長さを計算
Dim lenToExtract As Long
lenToExtract = endPos - startPos + 1
If lenToExtract > 0 Then
extractedName = Mid(txt, startPos, lenToExtract)
extractedName = Trim(extractedName)
' extractedName には「ヤマダ」のような文字列が入る
Else
extractedName = "" ' 抽出できる文字列がない場合
End If
' 抽出した名前をフォルダ名に使用する
If extractedName <> "" Then
' ★ 名前の中の半角スペース・全角スペースをすべて削除
namePartToUse = Replace(extractedName, " ", "")
namePartToUse = Replace(namePartToUse, " ", "")
Else
' 「顧客：」は見つかったが、その後に名前がなかった場合
namePartToUse = ""
End If
ElseIf p1 > 0 And p2 > p1 Then
' 「顧客：」は見つからなかったが、「名前：」と「顧客」の間から取得する（元のロジック）
namePartToUse = Mid(txt, p1 + Len("名前："), p2 - (p1 + Len("名前：")))
namePartToUse = Trim(namePartToUse)
If namePartToUse <> "" Then
' ★ 名前の中の半角スペース・全角スペースをすべて削除
namePartToUse = Replace(namePartToUse, " ", "")
namePartToUse = Replace(namePartToUse, " ", "")
End If
Else
' 「顧客：」も「名前：」と「顧客」の間も取得できなかった場合
namePartToUse = ""
End If
' フォルダ名の生成（namePartToUse が空でない場合のみ）
If namePartToUse <> "" Then
' ★ （北恵）の前にスペースを入れない
' 日付と名前の間だけ全角スペースを1つ残す
folderName = datePrefix & " " & namePartToUse & "様邸（北恵）" & tailText
folderName = CleanFileName(folderName)
If folderName <> "" Then
If Dir(basePath & folderName, vbDirectory) = "" Then
MkDir basePath & folderName
End If
End If
End If
End If
ユーザーの要望の再確認:
「（北恵）のカッコ内の文字を"顧客："の後ろの文字にして欲しい」
例：顧客：ヤマダ→様邸（ヤマダ）
この例は、フォルダ名が datePrefix & " " & namePartToUse & "様邸（北恵）" & tailText の形式であることを考えると、 namePartToUse の部分を「ヤマダ」にしたい、ということ。 そして、元のコードの namePart は「名前：」と「顧客」の間だった。 つまり、「名前：山田 顧客 △△」の場合、namePart は「山田 」だった。 ユーザーは「顧客：ヤマダ」という文字列から「ヤマダ」を取りたい。
修正後のコードでは、
extractedName として取得する。extractedName を整形して namePartToUse にする。namePartToUse を取得する。このロジックで、ユーザーの要望「（北恵）のカッコ内の文字を"顧客："の後ろの文字にして欲しい」が実現できる。 つまり、namePartToUse の部分が、
ただし、ユーザーの例「顧客：ヤマダ→様邸（ヤマダ）」は、 「様邸（北恵）」の「北恵」の部分を「ヤマダ」にしたい、という意図。 ということは、namePartToUse が「ヤマダ」になったら、 folderName = datePrefix & " " & namePartToUse & "様邸（北恵）" & tailText ではなく、 folderName = datePrefix & " " & namePartToUse & "様邸（" & namePartToUse & "）" & tailText としたい、ということか？
いや、ユーザーの指示は「（北恵）のカッコ内の文字を"顧客："の後ろの文字にして欲しい」なので、 「（北恵）」の部分を「（ヤマダ）」のようにしたい、ということ。 つまり、 folderName = datePrefix & " " & namePartToUse & "様邸（" & namePartToUse & "）" & tailText という形式にしたい、と解釈するのが自然。
再修正: folderName の生成部分を修正する。 folderName = datePrefix & " " & namePartToUse & "様邸（北恵）" & tailText ↓ folderName = datePrefix & " " & namePartToUse & "様邸（" & namePartToUse & "）" & tailText
これで、
namePartToUse は「ヤマダ」になる。日付 ヤマダ様邸（ヤマダ）tailText となる。もし「顧客：」が見つからず、元のロジックで namePartToUse が「山田」になった場合、
日付 山田様邸（山田）tailText となる。 この場合、元の「（北恵）」が消えてしまう。ユーザーの意図を再解釈: 「（北恵）のカッコ内の文字を"顧客："の後ろの文字にして欲しい」 これは、「（北恵）」という固定文字列を、namePartToUse の値で置き換えたい、ということ。 つまり、 folderName = datePrefix & " " & namePartToUse & "様邸（" & namePartToUse & "）" & tailText この形が正しい。
コードの最終調整: namePartToUse を取得するロジックは上記で良さそう。 フォルダ名生成部分を修正する。
' フォルダ名の生成（namePartToUse が空でない場合のみ）
If namePartToUse <> "" Then
' ★ （北恵）の代わりに、取得した名前を使用する
' 日付と名前の間だけ全角スペースを1つ残す
folderName = datePrefix & " " & namePartToUse & "様邸（" & namePartToUse & "）" & tailText
folderName = CleanFileName(folderName)
If folderName <> "" Then
If Dir(basePath & folderName, vbDirectory) = "" Then
MkDir basePath & folderName
End If
End If
End If
この修正で、ユーザーの要望「（北恵）のカッコ内の文字を"顧客："の後ろの文字にして欲しい」が実現できる。 「顧客：ヤマダ」があれば namePartToUse は「ヤマダ」になり、フォルダ名は「日付 ヤマダ様邸（ヤマダ）tailText」となる。 「顧客：」がなく、「名前：山田 顧客 △△」なら namePartToUse は「山田」になり、フォルダ名は「日付 山田様邸（山田）tailText」となる。
これは、元のコードの「（北恵）」という固定文字列を完全に削除し、
常に「様邸（取得した名前）」という形式にするということになる。
ユーザーの例「顧客：ヤマダ→様邸（ヤマダ）」は、この解釈で合っているはず。
もし、元の「（北恵）」を残しつつ、 「顧客：ヤマダ」の場合のみ「様邸（ヤマダ）」とし、 それ以外は「様邸（北恵）」としたい、という場合は、 folderName 生成部分の If namePartToUse <> "" Then の中で、 さらに条件分岐が必要になる。
しかし、指示は「（北恵）のカッコ内の文字を"顧客："の後ろの文字にして欲しい」なので、 「（北恵）」という固定文字を「"顧客："の後ろの文字」で置き換える、と解釈するのが最も素直。 つまり、namePartToUse が「ヤマダ」なら「様邸（ヤマダ）」、 namePartToUse が「山田」なら「様邸（山田）」、という形。
コードの提示方法：
コードのブロック: If Cells(i, col).DisplayFormat.Font.Bold = True Then の中の、 txt = Cells(i, col).Value の後から、 Next i の直前までを置き換える。
' --- 修正開始 ---
Dim p1 As Long, p2 As Long
p1 = InStr(txt, "名前：")
p2 = InStr(txt, "顧客") ' 「顧客」という単語の位置
Dim customerColonPos As Long
customerColonPos = InStr(txt, "顧客：") ' 「顧客：」という文字列の位置
Dim namePartToUse As String ' 最終的にフォルダ名に使う名前部分
Dim extractedName As String ' 「顧客：」から抽出した名前候補
If customerColonPos > 0 Then
' 「顧客：」が見つかった場合、その後の文字列を優先的に使用する
Dim startPos As Long
startPos = customerColonPos + Len("顧客：")
' 抽出する文字列の終了位置を決定する
' もし「顧客」という単語が「顧客：」の後にある場合、その手前まで
Dim customerWordPos As Long
customerWordPos = InStr(startPos, txt, "顧客")
Dim endPos As Long
If customerWordPos > 0 Then
endPos = customerWordPos - 1
Else
endPos = Len(txt)
End If
' 抽出する文字列の長さを計算
Dim lenToExtract As Long
lenToExtract = endPos - startPos + 1
If lenToExtract > 0 Then
extractedName = Mid(txt, startPos, lenToExtract)
extractedName = Trim(extractedName)
Else
extractedName = "" ' 抽出できる文字列がない場合
End If
' 抽出した名前をフォルダ名に使用する
If extractedName <> "" Then
' ★ 名前の中の半角スペース・全角スペースをすべて削除
namePartToUse = Replace(extractedName, " ", "")
namePartToUse = Replace(namePartToUse, " ", "")
Else
' 「顧客：」は見つかったが、その後に名前がなかった場合
namePartToUse = ""
End If
ElseIf p1 > 0 And p2 > p1 Then
' 「顧客：」は見つからなかったが、「名前：」と「顧客」の間から取得する（元のロジック）
namePartToUse = Mid(txt, p1 + Len("名前："), p2 - (p1 + Len("名前：")))
namePartToUse = Trim(namePartToUse)
If namePartToUse <> "" Then
' ★ 名前の中の半角スペース・全角スペースをすべて削除
namePartToUse = Replace(namePartToUse, " ", "")
namePartToUse = Replace(namePartToUse, " ", "")
End If
Else
' 「顧客：」も「名前：」と「顧客」の間も取得できなかった場合
namePartToUse = ""
End If
' フォルダ名の生成（namePartToUse が空でない場合のみ）
If namePartToUse <> "" Then
' ★ （北恵）の代わりに、取得した名前を使用する
' 日付と名前の間だけ全角スペースを1つ残す
folderName = datePrefix & " " & namePartToUse & "様邸（" & namePartToUse & "）" & tailText
folderName = CleanFileName(folderName)
If folderName <> "" Then
If Dir(basePath & folderName, vbDirectory) = "" Then
MkDir basePath & folderName
End If
End If
End If
' --- 修正終了 ---
このコードブロックを、元のコードの If Cells(i, col).DisplayFormat.Font.Bold = True Then の中の、 txt = Cells(i, col).Value の後から、Next i の直前までにある、 If p1 > 0 And p2 > p1 Then ... End If の部分と置き換える。
元のコードの If p1 > 0 And p2 > p1 Then のブロックは、 namePart を取得し、folderName を生成している部分。 このブロック全体を、上記で作成した新しいロジックで置き換える。
```vba
' 元のコードの該当部分（置き
[注意: 回答が長くなったため途中で切断されました。より具体的な質問で再度お試しください。]
このチャットはプライベートです。投稿者のみがメッセージを送信できます。
チャット内容の閲覧は可能です。
48 件のコメント