[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『セル内の、改行「 vbLf 」と戦う...マクロ!!』（あみな）
お世話になっております。 「 Excel VBA 」の初心者( ぴょぴょ ) です。 まだ、空が飛べないです。宜しくお願いします。 (o_ _)o
長文になりますので、お手すきの際に閲覧ください。 推定時間( 10分 )
セル内に複数の改行のある、縦型カレンダーがあります。 上記は、私が実際に業務で使用する物ではありません。 マクロの練習用に、自己課題として取り組んだ次第です。
※ 質問掲示板への投稿 [[20230417150547]] 『改行データに対応するｺｰﾄﾞを受動で入力したい。』（さまよえるたましい。）
さまよえるたましい。さんと、ほぼ同じ内容になっておりますが 関数での解決ではなく、VBAで処理をするのが課題です。 尚、レイアウトは自己課題を追加して、一部変更した内容となります。
マクロは...概ね完成しておりますが、一部だけどうしても 上手く行かない箇所がありまして、ご指導いただきたく思っております。
まずは、レイアウトのイメージをご確認ください。 尚、上手く行かない箇所は、後ほど説明をさせていただきます。
※ シートのレイアウトについて '************************************************************************************** 【 Sheet1 】レイアウト一部抜粋
|[A] |[B] |[C] |[D] |[E]
[1]|2023| 4|月 |EASY版
[2]
[3]|日付|曜日|イベント内容 |コード|担当
'----------------------------------------------
[4]| 1 | 土 |データ抽出10日分|E0100 |三浦
| | |データ送信 |A0100 |鈴木
| | |通知作成 | ←C4セルがここまで改行の意味
'----------------------------------------------
＊C列同様に、「 D列、E列 」も改行してデータを、別シートから反映します。 ＊イベント内容の名前に適応する、「 コード、担当者名 」を改行して別シート から反映させるマクロとなります。
【 Sheet2 】レイアウト( リスト ) 一部抜粋
|[A] |[B] |[C] |[D] |[E] |[F] |[G] |[H] |[I]
[1]|イベント名 |コード1|コード2|コード3|コード4|コード5|コード6|担当|担当
[2]|データ送信 |A0100 |A0101 |A0102 |A0103 |A0104 |A0105 |鈴木|鈴木
[3]|再データ抽出|B0100 |B0101 |B0102 |B0103 |B0104 |B0105 |斉藤|林
＊担当者名が 2列あるのは、レイアウトにより切り替えて反映させる為です。 ＊詳しくは、「 苗字について 」で説明をさせていただきます。
※ 実行マクロの概略説明 '************************************************************************************** ＊Sheet1 の「 C列 」セルに、複数の改行された業務内容( イベント名 )があります。
＊Sheet2 に( イベント名 )内容に適応する、コードと、担当者名がリストとなっており、 リストを Sheet1 へ反映させ、さらに重要な( イベント )については ( イベント名 )の「 フォントと、コード 」を赤色にします。 担当者名は、赤色では「不吉」という印象ですのでしません。
＊イベント内容は下記の 8種類なのですが、「 通知作成 」と「 引落 」は コードの必要がありません。
＊また、 8種類の中に同系の( イベント )があります。 それが、「 データ抽出10日分 」と 「 データ抽出25日分 」となります。
・データ送信 ・再データ抽出 ・データ後処理 ・会員用データ抽出 ・データ抽出10日分 ( 同系イベント ) ・データ抽出25日分 ( 同系イベント ) ・通知作成 ( コード必要なし ) ・引落 ( コード必要なし )
＊コードの先頭文字は、アルファベットで「 AからE 」の5種類です。 全てのコードが、「 A0100 」等の半角5文字で構成がされています。
＊コードと担当者名を反映させるのは、5つの( イベント )になり その中の重要なイベントのみ、フォントを赤色にします。
＊重要なイベントとは？ どれかと言うと、下記になります。 「 会員用データ抽出 」と「 コード 」のフォントを赤色にします。
＊ここ迄でレイアウトと、マクロの概要が理解できますでしょうか？ イメージはなんとなく解るかなと思いますが、詳細のレイアウトが無いと 無論ですが理解できないと思いまして、マクロで準備がしてあります。
＊実際のマクロを動かして頂いた方が早いので、レイアウトの作成から実行 迄の手順、及び( 問題の箇所 )を説明させていただきます。
※プロシージャについて '************************************************************************************** ★レイアウト作成用 ・Sub Input_rule() '' 入力規則設定 ・Sub VerticalCalendar_Make() '' 縦型カレンダー作成 ・Function production_Easydata(ByRef v As Long, ByRef data As String) ・Function production_Harddata(ByRef v As Long, ByRef data As String) ・Sub Sheet2_Make() '' Sheet2 のレイアウト作成用
★実行用 ・Sub GetEvent_Code() '' main 実行用 ・Function production_data(ByRef vdata As Variant)
★追求用 ・Sub 試験用() '' 上手く行かない箇所の追求用
＊八つのプロシージャがありまして、二つの試験用レイアウトがあります。 ＊私の個人的見解( マクロの難易度 )で [ 初級：Easy版 , 上級：Hard版 ] の 二つのレイアウトがありますが、入力規則で切り替えて使用します。 因みに、[ 中級：Normal版 ]はありません。
＊二つのレイアウトの違いは、担当者名の「 苗字 」の文字数による違いがあります。
・[ 初級：Easy版 ]では、担当者全員が 2文字の苗字です。
・[ 上級：Hard版 ]では、担当者全員の文字数がバラバラとなり
1文字〜最大5文字の苗字となります。
※ 問題の箇所について '************************************************************************************** ・[ 初級：Easy版 ] レイアウトで、Sub GetEvent_Code() '' main 実行用 を実行すると13行目が、下記のようになります。
|[A]|[B]|[C] |[D] |[E]
[13]| 10|月 |会員用データ抽出|D0101|菅沼 ← ココが問題の箇所です。
|データ後処理 |C0102|山田
|再データ抽出 |B0102|斉藤
|データ送信 |A0105|鈴木
《 問題の箇所について 》
＊C13セル 「 会員用データ抽出 」、D13「 D0101 」 のフォントが 赤色に「 1回目 」の実行では成功します。
しかしながら、もう一度実行をすると D13セルの全ての「コード」が赤色になってしまいます。 その原因が解らず、途方に暮れています。（ ; ; ）
＊ローカルウィンドウと、睨めっこ（ にらめっこ ）し原因を 探すも解らず 「 Sub 試験用() '' 上手く行かない箇所の追求用 」 にて debug.print するも解らず、お手上げ寸前です。
※レイアウトの準備 〜 実行についての手順です。 '************************************************************************************** 1.Sub Input_rule() '' 入力規則設定を実行すると、E1セルに 入力規則ができます。
2.入力規則の中から、EASYを選択します。 3.Sub VerticalCalendar_Make() '' 縦型カレンダー作成 を実行すると、EASY版レイアウトが完成します。
4.Sub Sheet2_Make() '' Sheet2 のレイアウト作成用を実行します。 Sheet2 にリストができます。
＊上記迄で、レイアウトの準備は終わりです。 ＊main ( Sheet1 ) へボタンを設置する場合は、上2行のF列から右に 配置するのがベストとなります。
5.Sub GetEvent_Code() '' main 実行用 をすると、完成します。 もう一度、連続で EASY版を実行すると失敗します。（ ; ; ）
※レイアウトの切替について '************************************************************************************** ＊D1セル : EASY版 と、E1セル : EASY に入力規則が設定された 時に、実行プロシージャがエラー無く走ります。
＊D1セル : EASY版 と、E1セル : HARD に入力規則が設定された 場合は、エラーになります。
HARD を実行する場合は、D1セルを HARD版に切り替えをしないと 実行プロシージャが正しく走らない為、雛形カレンダーを設定する プロシージャから変更しなければ、いけない使用となります。
※ 担当者の「 苗字について 」 '**************************************************************************************
＊Yahoo Japan 知恵袋によると、現在の日本人の苗字で 長い方で、最大6文字の方がいるかも？のようですが。。。 5文字の方さえも、お会いしたことが無いので設定は 最大5文字としました。
'******************************************************************************* : [ 苗字 ]左衛門三郎さんについて : 参考URL : 株式会社 小学館 https://hugkum.sho.jp/347846
: 6文字の苗字は存在するのでしょうか？ : Yahoo Japan 知恵袋 https://detail.chiebukuro.yahoo.co.jp/qa/question_detail/q1411699934 '******************************************************************************* 長い説明ですいません。(o_ _)o. ﾍﾟｺ 原因の追究を、お手伝いいただければ嬉しいです。
★コードはここからです。
Option Explicit Sub GetEvent_Code() '' main 実行用
Dim vSerch As Range
Dim dicObje As Object
Dim Evnt, cnt, data, Evnt_Code(), Rep(), One_Character, manager(5)
Dim str As String, pattern As String, keyword As String
Dim i&, v&, q&, k&, n&, j&, vp&, sp&
Dim num As Long, match As Long, LastRow As Long, LastCol As Long
Set dicObje = CreateObject("Scripting.Dictionary")
pattern = "*データ*"
keyword = "*会員用*"
With Sheets(2)
LastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
Set vSerch = .Range(.Cells(2, 1), .Cells(7, LastCol))
End With
With Sheets(1)
If .Cells(1, 4) Like "*E*" Then
If Not (.Cells(1, 4) Like "*E*" And _
.Cells(1, 5) Like "*E*") Then GoTo Err
Else
If Not (.Cells(1, 4) Like "*H*" And _
.Cells(1, 5) Like "*H*") Then GoTo Err
End If
LastRow = .Cells(.Rows.Count, 3).End(xlUp).Row
.Range(.Cells(4, 4), .Cells(LastRow, 5)).ClearContents
sp = IIf(Cells(1, 4) Like "*E*", 2, 5)
vp = IIf(Cells(1, 4) Like "*H*", 1, 0)
Application.ScreenUpdating = False
For q = 4 To LastRow
data = Split(.Cells(q, 3), vbLf)
ReDim Evnt_Code(Len(.Cells(q, 3)) - _
Len(Replace(.Cells(q, 3), vbLf, "")))
ReDim Rep(Len(.Cells(q, 3)) - _
Len(Replace(.Cells(q, 3), vbLf, "")))
For i = 0 To UBound(data)
If Not data(i) Like pattern Then
Evnt_Code(i) = Space(5)
Rep(i) = Space(sp)
Else
If Not dicObje.Exists(data(i)) Then
dicObje.Add Key:=data(i), Item:=1
Evnt_Code(i) = Application.VLookup(data(i), vSerch, 2, False)
Rep(i) = Application.VLookup(data(i), vSerch, 8 + vp, False)
manager(n) = Rep(i)
n = n + 1
Else
dicObje(data(i)) = dicObje(data(i)) + 1
Evnt_Code(i) = Application.VLookup(data(i), vSerch, dicObje(data(i)) + 1, False)
Rep(i) = Application.VLookup(data(i), vSerch, 8 + vp, False)
End If
End If
If Not .Cells(1, 5) Like "*E*" Then _
production_data Rep(i)
Next i
.Cells(q, 4) = Join(Evnt_Code, "")
.Cells(q, 5) = Join(Rep, "")
num = 5
If Right(.Cells(q, 4), 1) <> Chr(10) Then
For k = 1 To Len(.Cells(q, 4)) Step num
str = str & Mid(.Cells(q, 4), k, num) & Chr(10)
Next
.Cells(q, 4) = str: str = ""
Do While Right(.Cells(q, 4), 1) = vbLf
.Cells(q, 4) = Left(.Cells(q, 4), Len(.Cells(q, 4)) - 1)
.Cells(q, 4).VerticalAlignment = xlTop
Loop
End If
If Right(.Cells(q, 5), 1) <> Chr(10) Then
If .Cells(1, 5) Like "*E*" Then num = 2
For k = 1 To Len(.Cells(q, 5)) Step num
str = str & Mid(.Cells(q, 5), k, num) & Chr(10)
Next
.Cells(q, 5) = str: str = ""
Do While Right(.Cells(q, 5), 1) = vbLf
.Cells(q, 5) = Left(.Cells(q, 5), Len(.Cells(q, 5)) - 1)
.Cells(q, 5).VerticalAlignment = xlTop
Loop
End If
If .Cells(q, 3) Like keyword Then
For j = 1 To Len(.Cells(q, 3))
One_Character = Mid(.Cells(q, 3), j, 1)
If One_Character = "会" Then
match = j
.Cells(q, 3).Characters(match, 8).Font.Color = vbRed
End If
Next
For j = 1 To Len(.Cells(q, 4))
One_Character = Mid(.Cells(q, 4), j, 1)
If One_Character = "D" Then
match = j
.Cells(q, 4).Characters(match, 5).Font.Color = vbRed
End If
Next
End If
Erase Evnt_Code
Next q
.Columns(4).HorizontalAlignment = xlCenter
.Columns(5).EntireColumn.AutoFit
.Columns(5).HorizontalAlignment = xlCenter
Application.ScreenUpdating = True
End With
Evnt = dicObje.Keys
cnt = dicObje.items
For v = 0 To UBound(Evnt)
If Evnt(v) <> "" Then
With Sheets(2)
.Cells(v + 10, 1) = Evnt(v)
.Cells(v + 10, 2) = cnt(v) & "件"
.Cells(10, 3).Resize(UBound(manager) + 1) = _
Application.Transpose(manager)
End With
End If
Next v
Set dicObje = Nothing
Exit Sub
Err:
MsgBox "設定条件が揃っていない為、" & vbCrLf & _
"処理を実行できません", vbExclamation
End Sub
Function production_data(ByRef vdata As Variant)
Select Case LenB(vdata)
Case 2: vdata = vdata & Space(4)
Case 4: vdata = vdata & Space(3)
Case 6: vdata = vdata & Space(2)
Case 8: vdata = vdata & Space(1)
Case Else: vdata = vdata
End Select
End Function
Sub 試験用() '' 上手く行かない箇所の追求用
Dim i&, n&
Debug.Print "Len 文字数 : " & Len(ActiveCell.Value)
Debug.Print "LenB 文字数 : " & LenB(ActiveCell.Value)
Debug.Print "Conv 文字数 : " & LenB(StrConv(ActiveCell.Value, vbFromUnicode))
Debug.Print "セル内 vbLf 数 : " & Len(ActiveCell.Value) - _
Len(Replace(ActiveCell.Value, vbLf, ""))
n = Len(ActiveCell.Value) - _
Len(Replace(ActiveCell.Value, vbLf, ""))
Debug.Print "実際の文字数 : " & Len(ActiveCell.Value) - n
For i = 1 To Len(ActiveCell.Value)
Debug.Print Mid(ActiveCell.Value, i, 1)
Next
If InStr(ActiveCell.Value, vbLf) > 0 Then
Debug.Print "vbLfあり"
End If
If InStr(ActiveCell.Value, vbCr) > 0 Then
Debug.Print "vbCrあり"
End If
If InStr(ActiveCell.Value, vbCrLf) > 0 Then
Debug.Print "vbCrLfあり"
End If
Rem : 問題箇所の情報です。
'************************************
'' EASY版 [ D13 ]セルの結果
'' Len 文字数 : 23
'' LenB 文字数 : 46
'' Conv 文字数 : 23
'' セル内 vbLf 数 : 3
'' 実際の文字数 : 20
'************************************
End Sub
Sub VisualBasicEditor_ImidiateClear() '' Debug.Print一発削除
Application.VBE.Windows("イミディエイト").SetFocus
SendKeys " ^a", True
SendKeys "{DEL}", True
End Sub
Sub Input_rule() '' 入力規則設定
Sheets(1).UsedRange.Clear
With Sheets(1).[E1]
.Validation.Delete
.Validation.Add Type:=xlValidateList, Formula1:="設定,EASY,HARD"
.Font.Size = 9
.Font.Color = RGB(255, 20, 147)
.Interior.Color = RGB(255, 244, 243)
.Value = "設定"
.HorizontalAlignment = xlCenter
End With
End Sub
Sub VerticalCalendar_Make() '' 縦型カレンダー作成
Dim ws As Worksheet
Dim r As Range
Dim v, q, tmp, buf
Dim n&, x&
Dim Get_data As String
Dim keyword As String
Dim Layout_Settings As String
keyword = "*会員用データ抽出*"
Layout_Settings = "EASY"
Set ws = Sheets(1)
Application.ScreenUpdating = False
With ws
.[A3].CurrentRegion.Offset(1).Clear
.[A1] = 2023: .[B1] = 4: .[C1] = "月"
.[A3] = "日付": .[B3] = "曜日"
.[C3] = "イベント内容": .[D3] = "コード": .[E3] = "担当"
v = DateSerial(.[A1], .[B1], 1)
q = DateSerial(.[A1], .[B1] + 1, 0)
ReDim tmp(1 To 31, 1 To 2)
n = 0
For x = v To q
n = n + 1
tmp(n, 1) = x
tmp(n, 2) = x
If .[E1].Value = Layout_Settings Then
production_Easydata x, Get_data
.[C3].Offset(n) = Replace(Replace( _
Application.Trim(Get_data), " ", vbLf), " ", vbLf)
.[D1] = "EASY版"
.[D1].Font.Color = RGB(255, 20, 147)
.[D1].Interior.Color = RGB(255, 244, 243)
.[D1].Font.Size = 9
.[D1].HorizontalAlignment = xlCenter
Else
production_Harddata x, Get_data
.[C3].Offset(n) = Replace(Replace( _
Application.Trim(Get_data), " ", vbLf), " ", vbLf)
.[D1] = "HARD版"
.[D1].Font.Color = RGB(255, 20, 147)
.[D1].Interior.Color = RGB(255, 244, 243)
.[D1].Font.Size = 9
.[D1].HorizontalAlignment = xlCenter
End If
Next
.[A4].Resize(31, 2) = tmp
.[A3].Resize(31).NumberFormatLocal = "d"
.[B3].Resize(31).NumberFormatLocal = "aaa"
For Each r In .[A4].Resize(31)
If Format(r, "aaa") = "日" Then
r.Resize(, 2).Font.Color = vbRed
ElseIf Format(r, "aaa") = "土" Then
r.Resize(, 2).Font.Color = vbBlue
End If
Next
.[A:E].EntireColumn.AutoFit
.[E3].ColumnWidth = 10
.[E3].HorizontalAlignment = xlCenter
.[A3:D3].HorizontalAlignment = xlCenter
.[A3:B34].HorizontalAlignment = xlCenter
.[A3:E3].Interior.Color = RGB(240, 255, 255)
'' 罫線処理
.[A3].Resize(32, 5).Borders.LineStyle = xlDot '' 全体
.[A3:E34].BorderAround LineStyle:=xlContinuous '' 外枠
.[A3:E3].BorderAround LineStyle:=xlContinuous
.[B3:B34].Borders(xlEdgeLeft).LineStyle = xlHairline
.[B3:B34].Borders(xlEdgeLeft).Color = vbBlack
.[C3:C34].Borders(xlEdgeLeft).LineStyle = xlHairline
.[C3:C34].Borders(xlEdgeLeft).Color = vbBlack
.[D3:D34].Borders(xlEdgeLeft).LineStyle = xlHairline
.[D3:D34].Borders(xlEdgeLeft).Color = vbBlack
.[E3:E34].Borders(xlEdgeLeft).LineStyle = xlHairline
.[E3:E34].Borders(xlEdgeLeft).Color = vbBlack
ActiveWindow.DisplayGridlines = False '目盛線を非表示
n = 0
For Each r In .[C4:C34]
buf = r.Value
n = n + 1
Do While Right(buf, 1) = vbLf
buf = Left(buf, Len(r.Value) - 1)
r.VerticalAlignment = xlTop
Loop
.[C3].Offset(n) = buf
Next
End With
Application.ScreenUpdating = True
Erase tmp
End Sub
Function production_Easydata(ByRef v As Long, ByRef data As String)
Select Case CDate(v)
Case "2023/4/1": data = "データ抽出10日分 データ送信 通知作成"
Case "2023/4/2": data = "データ送信 再データ抽出"
Case "2023/4/3": data = "引落"
Case "2023/4/4": data = "データ送信 データ後処理"
Case "2023/4/5": data = "再データ抽出 通知作成"
Case "2023/4/6": data = "データ後処理"
Case "2023/4/7": data = "会員用データ抽出"
Case "2023/4/8": data = "データ抽出25日分 データ送信"
Case "2023/4/9": data = "データ送信"
Case "2023/4/10": data = "会員用データ抽出 データ後処理 再データ抽出 データ送信"
Case Else: data = ""
End Select
End Function
Function production_Harddata(ByRef v As Long, ByRef data As String)
Select Case CDate(v)
Case "2023/4/1": data = "データ抽出10日分 データ送信 通知作成"
Case "2023/4/2": data = "再データ抽出"
Case "2023/4/3": data = "データ後処理 通知作成 会員用データ抽出"
Case "2023/4/4": data = "データ後処理"
Case "2023/4/5": data = "引落 通知作成 再データ抽出"
Case "2023/4/6": data = "データ後処理"
Case "2023/4/7": data = "引落 会員用データ抽出 通知作成"
Case "2023/4/8": data = "データ抽出25日分 データ送信"
Case "2023/4/9": data = "データ送信"
Case "2023/4/10": data = "通知作成 データ後処理 会員用データ抽出 再データ抽出 "
Case Else: data = ""
End Select
End Function
Sub Sheet2_Make() '' Sheet2 のレイアウト作成用
Dim ws As Worksheet
If Sheets.Count = 1 Then Sheets.Add after:=Sheets(Sheets.Count)
Application.GoTo Worksheets(2).Cells(1, 1), True
Set ws = Sheets(2)
Application.ScreenUpdating = False
With ws
.[A1] = "イベント名"
.[A2] = "データ送信"
.[A3] = "再データ抽出"
.[A4] = "データ後処理"
.[A5] = "会員用データ抽出"
.[A6] = "データ抽出10日分"
.[A7] = "データ抽出25日分"
.[B1] = "コード1"
.[B2] = "A0100"
.[B3] = "B0100"
.[B4] = "C0100"
.[B5] = "D0100"
.[B6] = "E0100"
.[B7] = "E0101"
.[H1:I1] = "担当"
.[H2] = "鈴木": .[I2] = "鈴木"
.[H3] = "斉藤": .[I3] = "林"
.[H4] = "山田": .[I4] = "勅使河原"
.[H5] = "菅沼": .[I5] = "佐々木"
.[H6] = "三浦": .[I6] = "左衛門三郎"
.[H7] = "三浦": .[I7] = "左衛門三郎"
.[B1:B5].AutoFill Destination:=[B1:G5]
.[A1:I1].Interior.Color = RGB(240, 255, 255)
.[A:G].EntireColumn.AutoFit
.[H:I].ColumnWidth = 10
.[H1:I1].HorizontalAlignment = xlCenter
.[A1].CurrentRegion.Borders.LineStyle = xlHairline
End With
Application.ScreenUpdating = True
End Sub
※ その他 '************************************************************** ＊マクロのダメ出し ＊こんなマクロじゃ、最初から書き直した方が早い...とあらば 全訂正版のお手本を頂けると、もっと喜びます。(人´∀`)♪
＜ 使用 Excel：Excel2021、使用 OS：Windows11 ＞
セルのフォントの色が変わってしまったからでしょう。
（しんぷる） 2023/05/02(火) 16:08:32
これでわかるんじゃないかしら
Sub test()
With [a1]
.Value = "いろはに" & vbCrLf & "ほへと"
.Characters(1, 4).Font.Color = vbRed
MsgBox "いろはに だけ赤くなる"
.ClearContents
.Value = "ちりぬるを" & vbCrLf & "わかよたれそ"
MsgBox "一度消しても、キャラクターの色情報は残っている"
.Clear
.Value = "ういのおくやま" & vbCrLf & "けふこえて"
MsgBox "Clearなら全部消える"
End With
End Sub
（稲葉） 2023/05/02(火) 16:30:12
（しんぷる）さん、（稲葉）さん 返信をありがとうございます。
（稲葉）さん、 testマクロをありがとうございます。 そうなんです。質問する前に、Clear だと、罫線が消えるので
↓下記を一行追加したらならなかったので、 .Range(Cells(4, 3), Cells(34, 4)).Font.Color = vbBlack
何なんだろうと調べていたのですが
※ HARD版では、上記の一行を追記無しで...2回連続で実行しても
上手く行ってるんです…これはどうして上手く行くのでしょうか？
※ Characters くんを使う事が無かったので、今から調べてみます。 （あみな） 2023/05/02(火) 18:06:13
こっちの環境だとどっちでも全部赤くなるけど・・・ （稲葉） 2023/05/02(火) 19:13:18
(; ∀ ) ﾏﾁﾞﾃﾞｽｶ...嘘言うわけ無いですわねェ
私の、Excel ( 2021 )くん…HARD版で連続10回しても正常なのです。 対象の、1改行分以外は赤くならないんです。 だから、頭可笑しくなって来てて...
でも、お付き合いいただきありがとうございます。 どうしようも無い事が判明しました。 実家に帰った時に、Excel ( 2010 )くんで試してみます。
※お手間ですが...他の方で、もし情報を頂けたら 宜しくお願いします。 （あみな） 2023/05/02(火) 19:56:12
読み解くの大変だったけど、もう少し注釈入れたり、処理まとめると読みやすくなるかも・・・？
Sub GetEvent_Code() '' main 実行用
Dim vSerch As Range
Dim vp As Long, sp As Long
Dim LastRow As Long
Dim ev_cnt As Object: Set ev_cnt = CreateObject("Scripting.Dictionary")
Dim ev一覧 As Variant
Dim wsf As WorksheetFunction: Set wsf = Application.WorksheetFunction
Dim chrNum As Long
Dim rw As Long
Dim s As Variant, strEv As String, strRep As String
Const keyword As String = "会員用データ抽出"
With Sheets(2)
Set vSerch = .Range(.[a2], .Cells(7, .Cells(1, .Columns.Count).End(xlToLeft).Column))
End With
With Sheets(1)
Select Case Left(.[D1].Value, 1) & Left(.[E1].Value, 1)
Case "EE"
sp = 2
vp = 0
Case "HH"
sp = 5
vp = 1
Case Else
MsgBox "条件があっていないため、中断します"
Exit Sub
End Select
LastRow = .Cells(.Rows.Count, 3).End(xlUp).Row
.Range(.Cells(4, 4), .Cells(LastRow, 5)).ClearContents
For rw = 4 To LastRow
'イベントコード/担当者補完
strEv = ""
strRep = ""
For Each s In Split(.Cells(rw, "C").Value, vbLf)
If ev_cnt.exists(s) Then
ev_cnt(s) = ev_cnt(s) + 1
Else
ev_cnt(s) = 2
End If
strEv = strEv & vbLf & Application.IfError(Application.VLookup(s, vSerch, ev_cnt(s), 0), Space(5))
strRep = strRep & vbLf & Application.IfError(Application.VLookup(s, vSerch, 8 + vp, 0), Space(5))
Next s
.Cells(rw, "D") = Mid(strEv, 2)
.Cells(rw, "E") = Mid(strRep, 2)
'会員用データ抽出の文字に色つけ
With .Cells(rw, "C")
.Characters.Font.Color = 0
chrNum = InStr(.Value, keyword)
If chrNum > 0 Then
.Characters(chrNum, Len(keyword)).Font.Color = vbRed
End If
End With
'コードがDから始まるデータに色つけ
With .Cells(rw, "D")
.Characters.Font.Color = 0
chrNum = InStr(.Value, "D")
If chrNum > 0 Then
.Characters(chrNum, 5).Font.Color = vbRed
End If
End With
Next rw
.Columns(4).HorizontalAlignment = xlCenter
.Columns(5).EntireColumn.AutoFit
.Columns(5).HorizontalAlignment = xlCenter
End With
'件数出力
With Sheets(2)
ev一覧 = .Range(.[a2], .[a2].End(xlDown)).Resize(, 3).Value
For v = 1 To UBound(ev一覧, 1)
ev一覧(v, 2) = wsf.CountIf(Range("Sheet1!C:C"), "*" & ev一覧(v, 1) & "*") & "件"
ev一覧(v, 3) = Application.VLookup(ev一覧(v, 1), vSerch, 8 + vp, 0)
Next v
.[a1].End(xlDown).Offset(2).Resize(UBound(ev一覧, 1), UBound(ev一覧, 2)).Value = ev一覧
End With
MsgBox "完了しました"
End Sub
＞ num = 5 ＞ If Right(.Cells(q, 4), 1) <> Chr(10) Then ここから下の部分、まじで何がしたいかわからなかったから、省いちゃった
（稲葉） 2023/05/02(火) 20:29:24
Sub mp()
VerticalCalendar_Make
GetEvent_Code
End Sub
とかじゃダメなのですよね。。。毎回作り直しじゃ
むだっすよね。。。m(_ _)m
こちらでは
あみな先生のご説明通りの動作みたいですよ。
実験代行だけでも。。。(￣▽￣；)もう少し私も勉強してみます。
でわ
m(__)m
（隠居Z） 2023/05/02(火) 20:33:55
ｷﾀ━━━━｡ﾟ+.ヽ(´∀`*)ﾉ ﾟｷﾀ(・∀・)ｺﾚ+.ﾟ稲葉さん、ありがとうございます。 正常に、動いておりま〜す。
＊明日から分解処理して勉強します。
>ここから下の部分、まじで何がしたいかわからなかったから、省いちゃった
そこは、( ノ)ﾉーえｯトーー Joinくんで纏めて突っ込んで〜 ↓こんなかんじです。
・改行文字数を指定して ・範囲のデータを取得して ・セル内に改行が含まれるかチェックして ・指定文字数ごとに改行処理して ・無駄な改行コードを削除して ・配置を上詰めして
ってイメージダスキンです。Σヾ(･ω･´;)ﾉ━ 本当にありがとうございます。
※ IIFくんとられちゃったでorz （あみな） 2023/05/02(火) 21:36:11
(*´∀`*)ﾉｺﾝﾊﾞﾝ?h---（隠居Z）さまっ〜〜〜〜〜〜〜〜〜
しょっちゅう見てる気がしてますが..（ゝω・）vｷｬﾋﾟ 解決方法案をありがとうございます。 ちょっと、今からしてみます。
＞あみな先生のご説明通りの動作みたいですよ うちが先生では、「 Excel VBA 」する人は、皆先生だォ
因みに、（隠居Z）さまはバージョンなんでしたっけ？ 2019 でしたっけ？ （あみな） 2023/05/02(火) 21:38:49
A.1年間無償の Office 365 サービスが付いています。2年目以降サービスを継続する場合は有償に
なります。
Office 365 サービスは、OneDrive の1TBの利用、skypeの利用、テクニカルサポートなどです。
A.はは既に切れています ＾＾；
で〜す。
(*^^*)///。。。m(_ _)m
（隠居Z） 2023/05/02(火) 22:10:47
(*Ü*)ﾉ☆*。（隠居Z）さま〜〜〜〜〜。
↓これでもちゃんと動くでありますね。無駄あるけどw
Sub mp()
VerticalCalendar_Make
GetEvent_Code
End Sub
詳しいバージョンをありがとうございます。 そんなに詳しく…(笑)
ぉ ゃd(*ゝωб*)bすみ*─(б´∀`)ｸﾞｯﾅｲちゃんです｡+ﾟo｡｡ （あみな） 2023/05/02(火) 22:47:22
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.