Excel2021のVBAコードについて教えてください。 Excelの表を修正するVBAコードを書きたいです。 画像の1行目が見出し、2行目以降は値が何か入っているとしたとき、1行目の名前被りを失くしたいです。 1.特定の見出しの時指定の文字を足したい 見出しの名前被りがわかっている分は指定の文字を入れたいです。 例えば『見出し』は必ず被るので1個目は『見出し”の1個目”』2個目は『見出し”の備考”』のように””で囲んだ名前を入れる方法を教えてください 2.そのほかは『_1』『_2』を足したい 1で指定した見出し名以外でかぶっていた時は1個目に『_1』を2個目に『_2』を見出しの後ろに足したいです。 見出しは必ず被っているわけではなく、被っていたら2の処理をしたいです。 量的に手直しは厳しくVBAでコードを組んで解決したいのでよろしくお願いします

画像

Visual Basic | Excel148閲覧xmlns="http://www.w3.org/2000/svg">100

ベストアンサー

この回答はいかがでしたか? リアクションしてみよう

ThanksImg質問者からのお礼コメント

皆様ありがとうございました! とても勉強になりました。 ベストアンサーは個人的に一番わかりやすかったコードを書いてくださった方を選びました。

お礼日時:10/10 11:32

その他の回答(3件)

実際に「見出し」という文字列なんでしょうか? そうじゃないとして、末尾に数字がないものを親見出し、あるものを子見出しとした例です。 冗長なコードになってしまいましたが…。 Sub Sample() 'Microsoft Scripting Runtime を参照設定しておく Dim fso As Scripting.FileSystemObject Set fso = New Scripting.FileSystemObject Dim f As Long, n As Long Dim buf As Range, tmp As Range, fnd As Range, c As Range Dim key As String Dim sh1 As Worksheet, sh2 As Worksheet Set sh1 = Sheets("Sheet1") 'データ元シート Set c = sh1.Cells(1, Columns.Count).End(xlToLeft) Set buf = sh1.Range("A1", c) 'データ範囲 Set sh2 = Sheets("Sheet2") '作業用シート '最初に見つかった「末尾に数字無し」の項目を「親見出し」と判定する For Each tmp In buf If Not tmp.Value Like "*[0-9]" Then _ key = tmp.Value: Exit For Next tmp '親見出しの処理 Set fnd = buf.Find(key, LookAt:=xlWhole, After:=c) sh2.Range(fnd.Address).Value = key & "の1個目" f = fnd.Column Do With sh2.Range(fnd.Address) n = n + 1 Select Case n Case 2: .Value = key & "の備考" Case Is > 2: .Value = key & "_" & n End Select Set fnd = buf.FindNext(fnd) End With Loop Until fnd.Column = f '子見出しの処理 For Each tmp In buf If tmp.Value Like "*[0-9]" Then If WorksheetFunction.CountIf(buf, tmp.Value) > 1 Then Set fnd = buf.Find(tmp.Value, LookAt:=xlWhole, After:=c) n = 1 f = fnd.Column sh2.Range(fnd.Address).Value = tmp.Value & "_1" Do Set fnd = buf.FindNext(fnd) If fnd.Column = f Then Exit Do Else n = n + 1 sh2.Range(fnd.Address).Value = tmp.Value & "_" & n End If Loop Else: sh2.Range(tmp.Address).Value = tmp.Value End If End If Next tmp Set fso = Nothing End Sub まんま書き換えではなく、作業用シートに転記する例です。 間違いがなければコピペで戻すというのを想定しています。

画像

ベタ書きで Sub sample() Dim ws As Worksheet Set ws = ActiveSheet Dim lastCol As Long lastCol = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column Dim Rng As Range Set Rng = Range("A1", Cells(1, lastCol)) Dim dict As Object Set dict = CreateObject("Scripting.Dictionary") Dim i As Long, cnt_n As Long Dim hdr As String Const 特定 As String = "見出し" For i = 1 To lastCol hdr = ws.Cells(1, i).Value ' 特定見出し「見出し」の場合 If hdr = 特定 Then If Not dict.exists(hdr) Then ws.Cells(1, i).Value = hdr & "の1個目" dict.Add hdr, 1 Else If Application.CountIf(Rng, hdr & "の備考*") >= 1 Then ws.Cells(1, i).Value = hdr & "の備考" & "_" & dict(hdr) dict(hdr) = dict(hdr) + 1 Else If Application.CountIf(Rng, hdr) > 1 Then ws.Cells(1, i).Value = hdr & "の備考" & dict(hdr) Else ws.Cells(1, i).Value = hdr & "の備考" End If dict(hdr) = dict(hdr) + 1 End If End If Else ' その他の見出し If Not dict.exists(hdr) Then dict.Add hdr, 1 If dict(hdr) = 1 And Application.CountIf(Rng, hdr) = 1 Then ws.Cells(1, i).Value = hdr Else ws.Cells(1, i).Value = hdr & "_1" End If Else cnt_n = dict(hdr) + 1 ws.Cells(1, i).Value = hdr & "_" & cnt_n dict(hdr) = cnt_n End If End If Next i End Sub

シートの1行目が見出し 同じ見出しが重複している場合、重複を解消する 特定の見出し(例:「見出し」)は、1個目・2個目で指定文字列(例:「の1個目」「の備考」)を足す(3個以上あるときは の備考_1とする 3個目以降は「の備考_数値」とする その他の見出しは自動で _1, _2 を後ろに追加 左からカウントアップする

3個目があったらどうします? 添付図でいいですか? Sub 見出し修正() Dim c As Long, lastC As Long, cnt As Long, cnts As String lastC = Cells(1, Columns.Count).End(xlToLeft).Column For c = lastC To 2 Step -1 If Cells(1, c) = "見出し" Then cnt = Application.CountIf(Range(Cells(1, 1), Cells(1, c)), "見出し") Cells(1, c) = "見出しの備考-" & cnt End If Next For c = lastC To 2 Step -1 cnt = Application.CountIf(Range(Cells(1, 1), Cells(1, c)), Cells(1, c)) If cnt > 1 Then cnts = "-" & cnt Else cnts = "" End If Cells(1, c) = Cells(1, c) & cnts Next Cells(1, 1) = "見出しの1個目" End Sub

画像