条件に応じてコピー

Sub CopyFormulasBasedOnCriteria()
    Dim wsSource As Worksheet
    Dim wsTemplate As Worksheet
    Dim lastRow As Long
    Dim i As Long
    Dim copyRow As Long
    Dim pasteRow As Long

    ' シートをセットアップ
    Set wsSource = ThisWorkbook.Sheets("Data")
    Set wsTemplate = ThisWorkbook.Sheets("ひな形")

    ' 最終行を取得
    lastRow = wsSource.Cells(wsSource.Rows.Count, "C").End(xlUp).Row

    ' C列をループ
    For i = 1 To lastRow
        ' C列の値をチェック
        If wsSource.Cells(i, "C").Value = "AAAA" Then
            copyRow = 2
        ElseIf wsSource.Cells(i, "C").Value = "BBBB" Then
            copyRow = 4
        ElseIf wsSource.Cells(i, "C").Value = "CCCC" Then
            copyRow = 6
        Else
            ' 他の場合はスキップ
            Continue For
        End If

        ' コピー元の範囲を定義
        wsTemplate.Range("N" & copyRow & ":U" & copyRow).Copy

        ' 貼り付け先の行を計算
        pasteRow = i

   ' N列に貼り付け（値のみ）
        ’wsSource.Range("N" & pasteRow).PasteSpecial Paste:=xlPasteValues

  ' N列に貼り付け（計算式を含んだまま）
        wsSource.Range("N" & pasteRow).PasteSpecial Paste:=xlPasteFormulas
        Application.CutCopyMode = False ' コピー解除
    Next i
End Sub

判別して記入

Sub 判別して記入()
    Dim ws1 As Worksheet
    Dim ws2 As Worksheet
    Dim lastRow1 As Long
    Dim lastRow2 As Long
    Dim keyRange As Range
    Dim cell As Range
    Dim keyArray() As Variant
    Dim keyIndex As Long
    Dim labels() As String
    Dim labelIndex As Long
    Dim label As String
    
    ' シート1とシート2を設定
    Set ws1 = ThisWorkbook.Sheets("Sheet1")
    Set ws2 = ThisWorkbook.Sheets("Sheet2")
    
    ' シート1の最終行を取得
    lastRow1 = ws1.Cells(ws1.Rows.Count, "C").End(xlUp).Row
    
    ' シート2のキーの範囲を配列に読み込む
    lastRow2 = ws2.Cells(ws2.Rows.Count, "A").End(xlUp).Row
    keyArray = ws2.Range("A1:A" & lastRow2).Value
    
    ' シート1の各セルについて処理
    For Each cell In ws1.Range("C1:C" & lastRow1)
        If cell.Value <> "" Then
            ' カンマで区切られたラベルを配列に格納
            labels = Split(cell.Value, ",")
            
            ' ラベルの配列に対して処理
            For labelIndex = LBound(labels) To UBound(labels)
                label = Trim(labels(labelIndex)) ' ラベルの前後の空白を削除
                
                If label <> "" Then ' 空のラベルは無視
                
                    ' キーのチェック
                     For keyIndex = LBound(keyArray, 1) To UBound(keyArray, 1)
                         If InStr(1, label, keyArray(keyIndex, 1)) > 0 Then
                             label = "keyword1"
                             Exit For
                         End If
                     Next keyIndex
                
                    ' 最初の文字が3、4、または5の場合
                    If Left(label, 1) Like "[3456]" Then
                        label = "判別11"

   ''' ' セルの背景色を黄色に設定
  '''  cell.Interior.Color = RGB(255, 255, 0) ' 黄色                        

                     Else
                        ' 最初の文字がアルファベットの場合
                        If Asc(UCase(Left(label, 1))) >= 65 And Asc(UCase(Left(label, 1))) <= 90 Then
                            label = "判別12"                            
                         Else
                            ' 1234と5678の場合
                            Select Case label
                                Case "1234"
                                    label = "判別13"
                                Case "5678"
                                    label = "判別14"
                                Case "1111"
                                    label = "判別15"
                                Case "2222"
                                    label = "判別61"
                                Case Else

                            End Select
                          End If
                    End If
                    
                    ' 最初のラベルが空でない場合
                    If label <> "" Then
                        ' 既存のD列の値にラベルを追加
                        If ws1.Cells(cell.Row, "D").Value <> "" Then
                            ws1.Cells(cell.Row, "D").Value = ws1.Cells(cell.Row, "D").Value & "," & label
                        Else
                            ws1.Cells(cell.Row, "D").Value = label
                        End If
                    End If
                End If
            Next labelIndex
        End If
    Next cell
End Sub

コピー転記してから色付け

Sub コピー転記してから色付け()
    Dim wsSource As Worksheet
    Dim wsDestination As Worksheet
    Dim wsKeywords As Worksheet
    Dim lastRowSource As Long
    Dim lastRowKeywords As Long
    Dim i As Long
    Dim j As Long
    Dim keyword As String
    
    ' Sheet1をソース、Sheet2を転記先、Sheet3をキーワードのシートに設定
    Set wsSource = ThisWorkbook.Sheets("Sheet1")
    Set wsDestination = ThisWorkbook.Sheets("Sheet2")
    Set wsKeywords = ThisWorkbook.Sheets("Sheet3")
    
    ' ソースの最終行を取得
    lastRowSource = wsSource.Cells(wsSource.Rows.Count, "A").End(xlUp).Row
    ' キーワードの最終行を取得
    lastRowKeywords = wsKeywords.Cells(wsKeywords.Rows.Count, "A").End(xlUp).Row
    
    ' ソースからデータを転記
    For i = 1 To lastRowSource
        ' A列からD列とF列のデータをE列に転記
        wsDestination.Cells(i, "A").Value = wsSource.Cells(i, "A").Value
        wsDestination.Cells(i, "B").Value = wsSource.Cells(i, "B").Value
        wsDestination.Cells(i, "C").Value = wsSource.Cells(i, "C").Value
        wsDestination.Cells(i, "D").Value = wsSource.Cells(i, "D").Value
        wsDestination.Cells(i, "E").Value = wsSource.Cells(i, "F").Value
        
        ' E列のセルがSheet3のA列に記載されているキーワードを含む場合は黄色にする
        For j = 1 To lastRowKeywords
            keyword = wsKeywords.Cells(j, "A").Value
            If InStr(1, wsDestination.Cells(i, "E").Value, keyword) > 0 Then
                wsDestination.Cells(i, "E").Interior.Color = RGB(255, 255, 0) ' 黄色
                wsDestination.Cells(i, "F").Value = "●"
                Exit For ' 一度でも条件に合致したらループを抜ける
            End If
        Next j
    Next i

End Sub

'//--------------------配列パターン

Sub CopyAndHighlight()
    Dim wsSource As Worksheet
    Dim wsDestination As Worksheet
    Dim wsKeywords As Worksheet
    Dim lastRowSource As Long
    Dim lastRowKeywords As Long
    Dim dataRange As Variant
    Dim keywordsRange As Variant
    Dim i As Long
    Dim j As Long
    Dim keyword As String
    
    ' Sheet1をソース、Sheet2を転記先、Sheet3をキーワードのシートに設定
    Set wsSource = ThisWorkbook.Sheets("Sheet1")
    Set wsDestination = ThisWorkbook.Sheets("Sheet2")
    Set wsKeywords = ThisWorkbook.Sheets("Sheet3")
    
    ' ソースのデータを配列に読み込む
    lastRowSource = wsSource.Cells(wsSource.Rows.Count, "A").End(xlUp).Row
    dataRange = wsSource.Range("A1:F" & lastRowSource).Value
    
    ' キーワードのデータを配列に読み込む
    lastRowKeywords = wsKeywords.Cells(wsKeywords.Rows.Count, "A").End(xlUp).Row
    keywordsRange = wsKeywords.Range("A1:A" & lastRowKeywords).Value
    
    ' ソースからデータを転記
    For i = 1 To UBound(dataRange, 1)
        ' A列からD列とF列のデータをE列に転記
        For j = 1 To 4
            wsDestination.Cells(i, j).Value = dataRange(i, j)
        Next j
        wsDestination.Cells(i, 5).Value = dataRange(i, 6)
        
        ' E列のセルがSheet3のA列に記載されているキーワードを含む場合は黄色にする
        For j = 1 To UBound(keywordsRange, 1)
            keyword = keywordsRange(j, 1)
            If InStr(1, dataRange(i, 6), keyword) > 0 Then
                wsDestination.Cells(i, 5).Interior.Color = RGB(255, 255, 0) ' 黄色
                wsDestination.Cells(i, 6).Value = "●"
                Exit For ' 一度でも条件に合致したらループを抜ける
            End If
        Next j
    Next i
End Sub

 

振分 (正規表現)

Sub UpdateDColumnWithRegex()
    Dim regex As Object
    Dim lastRow As Long
    Dim i As Long
    
    ' 正規表現オブジェクトを作成
    Set regex = CreateObject("VBScript.RegExp")
    
    ' パターンを設定
    regex.IgnoreCase = True
    regex.Global = True
    
    ' 最終行を取得
    lastRow = Cells(Rows.Count, "C").End(xlUp).Row
    
    ' ループして条件に基づいてD列を更新
    For i = 1 To lastRow
        ' 文字列から最初の文字を取得
        Dim firstChar As String
        firstChar = Left(Cells(i, "C").Value, 1)
        
        ' 正規表現パターンに一致するかチェック
        If firstChar Like "#" Then
            If Left(Cells(i, "C").Value, 2) = "test1" Or Left(Cells(i, "C").Value, 2) = "test2" Then
                Cells(i, "D").Value = "その他２"
            Else
                Cells(i, "D").Value = "その他"
            End If
        ElseIf regexTest(regex, Cells(i, "C").Value, "TNY.*Z.*") Then
            Cells(i, "D").Value = "A211"
        ElseIf regexTest(regex, Cells(i, "C").Value, "TNY.*Y.*") Then
            Cells(i, "D").Value = "A211"
        ElseIf regexTest(regex, Cells(i, "C").Value, "TNY.*X.*") Then
            Cells(i, "D").Value = "A213"
        ElseIf regexTest(regex, Cells(i, "C").Value, "TNY.*") Then
            Cells(i, "D").Value = "A213"
        ElseIf regexTest(regex, Cells(i, "C").Value, "TRY.*") Then
            Cells(i, "D").Value = "B222"
        Else
            Cells(i, "D").Value = "A211"
        End If
    Next i
    
    ' 正規表現オブジェクトを解放
    Set regex = Nothing
End Sub

Function regexTest(regex As Object, str As String, pattern As String) As Boolean
    regex.Pattern = pattern
    regexTest = regex.Test(str)
End Function

2つのKEYを比較し、お互いに存在しないKEYを別シートに抽出する

Sub 比較と記載1()

’Dictionaryにてremoveメソッド利用(ないものを削除パターン)

    Dim ws As Worksheet
    Dim lastRow1, lastRow2 As Long
    Dim aRange As Range, cRange As Range
    Dim aValue As Variant, cValue As Variant
    Dim compareColumnA As Range, compareColumnC As Range
    Dim resultDictA As Object, resultDictC As Object
    Dim i As Long
    
    ' 対象のシートを設定
    Set ws = ThisWorkbook.Sheets("Sheet1") ' シート名を変更する必要があるかもしれません
    
    ' 比較する列を選択
    On Error Resume Next
    Set compareColumnA = Application.InputBox("比較する列Aを選択してください", Type:=8)
    On Error GoTo 0
    If compareColumnA Is Nothing Then Exit Sub ' ユーザーがキャンセルした場合、処理を終了
    
    On Error Resume Next
    Set compareColumnC = Application.InputBox("比較する列Cを選択してください", Type:=8)
    On Error GoTo 0
    If compareColumnC Is Nothing Then Exit Sub ' ユーザーがキャンセルした場合、処理を終了
    
    ' 最終行を取得
    lastRow1 = ws.Cells(ws.Rows.Count, compareColumnA.Column).End(xlUp).Row
    lastRow2 = ws.Cells(ws.Rows.Count, compareColumnC.Column).End(xlUp).Row
    
    ' 比較対象の列を設定
    Set aRange = ws.Range(compareColumnA.Offset(1), compareColumnA.Offset(lastRow1 - 1))
    Set cRange = ws.Range(compareColumnC.Offset(1), compareColumnC.Offset(lastRow2 - 1))
    
    ' 空のディクショナリを作成
    Set resultDictA = CreateObject("Scripting.Dictionary")
    Set resultDictC = CreateObject("Scripting.Dictionary")
    
    ' a列の値をディクショナリに追加
    For Each aValue In aRange
        resultDictA(aValue) = aValue
    Next aValue
    
    ' c列の値をディクショナリに追加
    For Each cValue In cRange
        resultDictC(cValue) = cValue
    Next cValue
    
    ' 重複するキーを削除
    For Each aValue In resultDictA.Keys
        If resultDictC.Exists(aValue) Then
            resultDictA.Remove aValue
            resultDictC.Remove aValue
        End If
    Next aValue
    
    ' 結果を出力
    Dim resultSheet As Worksheet
    Set resultSheet = ThisWorkbook.Sheets.Add ' 新しいシートを作成して結果を記録
    
    ' ヘッダーを設定
    resultSheet.Cells(1, 1).Value = "列Aにのみ存在"
    resultSheet.Cells(1, 2).Value = "列Cにのみ存在"
    
    ' 結果を出力
    Dim rowIndex As Long
    rowIndex = 2 ' ヘッダーの下から始める
    
    For Each aValue In resultDictA.Keys
        resultSheet.Cells(rowIndex, 1).Value = aValue
        rowIndex = rowIndex + 1
    Next aValue
    
    rowIndex = 2 ' ヘッダーの下から始める
    
    For Each cValue In resultDictC.Keys
        resultSheet.Cells(rowIndex, 2).Value = cValue
        rowIndex = rowIndex + 1
    Next cValue
    
End Sub

Sub 比較と記載2()

'’Dictionaryにて、比較結果パターン

    Dim ws As Worksheet
    Dim lastRow1, lastRow2 As Long
    Dim aRange As Range, cRange As Range
    Dim aValue As Variant, cValue As Variant
    Dim i As Long
    Dim compareColumnA As Range, compareColumnC As Range
    Dim resultDictA As Object, resultDictC As Object
    
    ' 対象のシートを設定
    Set ws = ThisWorkbook.Sheets("Sheet1") ' シート名を変更する必要があるかもしれません
    
    ' 比較する列を選択
    On Error Resume Next
    Set compareColumnA = Application.InputBox("比較する列Aを選択してください", Type:=8)
    On Error GoTo 0
    If compareColumnA Is Nothing Then Exit Sub ' ユーザーがキャンセルした場合、処理を終了
    
    On Error Resume Next
    Set compareColumnC = Application.InputBox("比較する列Cを選択してください", Type:=8)
    On Error GoTo 0
    If compareColumnC Is Nothing Then Exit Sub ' ユーザーがキャンセルした場合、処理を終了
    
    ' 最終行を取得
    lastRow1 = ws.Cells(ws.Rows.Count, compareColumnA.Column).End(xlUp).Row
    lastRow2 = ws.Cells(ws.Rows.Count, compareColumnC.Column).End(xlUp).Row
    
    ' 比較対象の列を設定
    Set aRange = ws.Range(compareColumnA.Offset(1), compareColumnA.Offset(lastRow1 - 1))
    Set cRange = ws.Range(compareColumnC.Offset(1), compareColumnC.Offset(lastRow2 - 1))
    
    ' 空のディクショナリを作成
    Set resultDictA = CreateObject("Scripting.Dictionary")
    Set resultDictC = CreateObject("Scripting.Dictionary")
    
    ' a列にしかない値をディクショナリに追加
    For Each aValue In aRange
        If IsError(Application.Match(aValue, cRange, 0)) Then
            If Not resultDictA.Exists(aValue) Then
                resultDictA.Add aValue, aValue
            End If
        End If
    Next aValue
    
    ' c列にしかない値をディクショナリに追加
    For Each cValue In cRange
        If IsError(Application.Match(cValue, aRange, 0)) Then
            If Not resultDictC.Exists(cValue) Then
                resultDictC.Add cValue, cValue
            End If
        End If
    Next cValue
    
    ' 結果を出力
    Dim resultSheet As Worksheet
    Set resultSheet = ThisWorkbook.Sheets.Add ' 新しいシートを作成して結果を記録
    
    ' ヘッダーを設定
    resultSheet.Cells(1, 1).Value = "列Aにのみ存在"
    resultSheet.Cells(1, 2).Value = "列Cにのみ存在"
    
    ' 結果を出力
    Dim rowIndex As Long
    rowIndex = 2 ' ヘッダーの下から始める
    
    For Each aValue In resultDictA.Keys
        resultSheet.Cells(rowIndex, 1).Value = aValue
        rowIndex = rowIndex + 1
    Next aValue
    
    rowIndex = 2 ' ヘッダーの下から始める
    
    For Each cValue In resultDictC.Keys
        resultSheet.Cells(rowIndex, 2).Value = cValue
        rowIndex = rowIndex + 1
    Next cValue
    
End Sub

ヒットする項目を抽出する

Sub TransferData()
    Dim ws1 As Worksheet
    Dim ws2 As Worksheet
    Dim lastRow1 As Long
    Dim lastRow2 As Long
    Dim i As Long
    Dim j As Long
    Dim keyA As String
    Dim keyB As String
    Dim matchFound As Boolean
    
    ' Sheet1とSheet2を設定
    Set ws1 = ThisWorkbook.Sheets("Sheet1")
    Set ws2 = ThisWorkbook.Sheets("Sheet2")
    
    ' Sheet1とSheet2の最終行を取得
    lastRow1 = ws1.Cells(ws1.Rows.Count, "A").End(xlUp).Row
    lastRow2 = ws2.Cells(ws2.Rows.Count, "A").End(xlUp).Row
    
    ' Sheet1を走査してSheet2と比較
    For i = 2 To lastRow1 ' ヘッダー行をスキップ
        keyA = ws1.Cells(i, 1).Value
        keyB = ws1.Cells(i, 2).Value
        matchFound = False
        
        ' Sheet2の行を走査して一致するデータを探す
        For j = 2 To lastRow2 ' ヘッダー行をスキップ
            If ws2.Cells(j, 1).Value = keyA And ws2.Cells(j, 2).Value = keyB Then
                ' 一致するデータが見つかった場合
                If matchFound Then
                    ' 複数の一致がある場合、カンマで区切ってD列に追記
                    ws1.Cells(i, 4).Value = ws1.Cells(i, 4).Value & ", " & ws2.Cells(j, 3).Value
                Else
                    ' 最初の一致の場合は単に値を転記
                    ws1.Cells(i, 4).Value = ws2.Cells(j, 3).Value
                    matchFound = True
                End If
            End If
        Next j
    Next i
End Sub
Sub TransferData2()
    Dim ws1 As Worksheet
    Dim ws2 As Worksheet
    Dim lastRow1 As Long
    Dim lastRow2 As Long
    Dim i As Long
    Dim j As Long
    Dim keyA As String
    Dim keyB As String
    Dim matchFound As Boolean
    
    ' Sheet1とSheet2を設定
    Set ws1 = ThisWorkbook.Sheets("Sheet1")
    Set ws2 = ThisWorkbook.Sheets("Sheet2")
    
    ' Sheet1とSheet2の最終行を取得
    lastRow1 = ws1.Cells(ws1.Rows.Count, "A").End(xlUp).Row
    lastRow2 = ws2.Cells(ws2.Rows.Count, "A").End(xlUp).Row
    
    ' Sheet1を走査してSheet2と比較
    For i = 2 To lastRow1 ' ヘッダー行をスキップ
        keyA = ws1.Cells(i, 1).Value
        keyB = ws1.Cells(i, 2).Value
        matchFound = False
        
        ' Sheet2の行を走査して一致するデータを探す
        For j = 2 To lastRow2 ' ヘッダー行をスキップ
            If ws2.Cells(j, 1).Value = keyA And ws2.Cells(j, 2).Value = keyB Then
                ' 一致するデータが見つかった場合
                If matchFound Then
                    ' 複数の一致がある場合、カンマで区切ってD列に追記
                    ws1.Cells(i, 4).Value = ws1.Cells(i, 4).Value & "; " & ws2.Cells(j, 3).Value & "; " & ws2.Cells(j, 4).Value
                Else
                    ' 最初の一致の場合は単に値を転記
                    ws1.Cells(i, 4).Value = ws2.Cells(j, 3).Value & "; " & ws2.Cells(j, 4).Value
                    matchFound = True
                End If
            End If
        Next j
    Next i
End Sub
Sub TransferData3()
    Dim ws1 As Worksheet
    Dim ws2 As Worksheet
    Dim lastRow1 As Long
    Dim lastRow2 As Long
    Dim i As Long
    Dim j As Long
    Dim keyA As String
    Dim keyB As String
    Dim matchFound As Boolean
    
    ' Sheet1とSheet2を設定
    Set ws1 = ThisWorkbook.Sheets("Sheet1")
    Set ws2 = ThisWorkbook.Sheets("Sheet2")
    
    ' Sheet1とSheet2の最終行を取得
    lastRow1 = ws1.Cells(ws1.Rows.Count, "A").End(xlUp).Row
    lastRow2 = ws2.Cells(ws2.Rows.Count, "A").End(xlUp).Row
    
    ' Sheet1を走査してSheet2と比較
    For i = 2 To lastRow1 ' ヘッダー行をスキップ
        keyA = ws1.Cells(i, 1).Value
        keyB = ws1.Cells(i, 2).Value
        matchFound = False
        
        ' Sheet2の行を走査して一致するデータを探す
        For j = 2 To lastRow2 ' ヘッダー行をスキップ
            If ws2.Cells(j, 1).Value = keyA And ws2.Cells(j, 2).Value = keyB Then
                ' 一致するデータが見つかった場合
                If matchFound Then
                    ' 複数の一致がある場合、セミコロンで区切ってD列に追記
                    ws1.Cells(i, 4).Value = ws1.Cells(i, 4).Value & "; " & Format(ws2.Cells(j, 3).Value, "0%") & "; " & Format(ws2.Cells(j, 4).Value, "0%")
                Else
                    ' 最初の一致の場合は単に値を転記
                    ws1.Cells(i, 4).Value = Format(ws2.Cells(j, 3).Value, "0%") & "; " & Format(ws2.Cells(j, 4).Value, "0%")
                    matchFound = True
                End If
            End If
        Next j
    Next i
End Sub

指定された日付から60日後の日付を計算

Sub 前日の日付を計算してセルに入力()
    Dim 検索日 As Date
    Dim 前日 As Date
    Dim 後日 As Date
    Dim フォーマット済み日付 As String
    Dim 休みの日 As Range
    
    ' セルA1に入力された日付を取得（ここではA1を例示しています）
    検索日 = Range("A1").Value
    
    ' 休みの日をシート2のA列から取得
    Set 休みの日 = Sheets("Sheet2").Range("A:A")
    
    ' 検索日の前日を計算
    前日 = WorksheetFunction.WorkDay(検索日, -1, 休みの日)
    
    ' 検索日の後60日を計算
    後日 = WorksheetFunction.WorkDay(検索日, 60, 休みの日)
    
    ' yyyymmdd形式に日付をフォーマット
    フォーマット済み日付 = Format(前日, "yyyymmdd")
    
    ' セルA2に前日の日付を入力
    Range("A2").Value = フォーマット済み日付
    
    ' セルA3の値をクリア
    Range("A3").ClearContents
    
    ' yyyymmdd形式に日付をフォーマット
    フォーマット済み日付 = Format(後日, "yyyymmdd")
    
    ' セルA3に後日の日付を入力
    Range("A3").Value = フォーマット済み日付
End Sub

ワークデイ関数を使って指定した日付の前日を計算

Sub 前日の日付を計算してセルに入力()
    Dim 検索日 As Date
    Dim 前日 As Date
    Dim フォーマット済み日付 As String
    Dim 休みの日 As Range
    
    ' セルA1に入力された日付を取得（ここではA1を例示しています）
    検索日 = Range("A1").Value
    
    ' 休みの日をシート2のA列から取得
    Set 休みの日 = Sheets("Sheet2").Range("A:A")
    
    ' 検索日の前日を計算
    前日 = Application.WorksheetFunction.WorkDay(検索日, -1, 休みの日)
    
    ' yyyymmdd形式に日付をフォーマット
    フォーマット済み日付 = Format(前日, "yyyymmdd")
    
    ' セルA2に前日の日付を入力
    Range("A2").Value = フォーマット済み日付
End Sub

指定年、月と前後月 土日検索

Sub ExtractWeekendAndHolidayDatesByMonth(yearToSearch As Integer, monthToSearch As Integer)
    Dim startDate As Date
    Dim endDate As Date
    Dim currentDate As Variant
    Dim ws As Worksheet
    Dim rowNum As Long
    Dim holidayDates As Variant
    Dim i As Integer
    
    ' 新しいシートを作成します
    Set ws = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
    ws.Name = "WeekendAndHolidayDates" ' シートの名前を設定します
    
    ' ヘッダーを設定します
    ws.Range("A1").Value = "Date"
    ws.Range("B1").Value = "Day"
    
    ' 開始日と終了日を設定します
    startDate = DateSerial(yearToSearch, monthToSearch, 1) ' 指定された年月の1日を取得
    endDate = DateSerial(yearToSearch, monthToSearch + 1, 0) ' 指定された年月の最終日を取得
    
    ' 前月の開始日と終了日を設定します
    Dim prevMonthStartDate As Date
    Dim prevMonthEndDate As Date
    prevMonthStartDate = DateSerial(yearToSearch, monthToSearch - 1, 1)
    prevMonthEndDate = DateSerial(yearToSearch, monthToSearch, 0)
    
    ' 翌月の開始日と終了日を設定します
    Dim nextMonthStartDate As Date
    Dim nextMonthEndDate As Date
    nextMonthStartDate = DateSerial(yearToSearch, monthToSearch + 1, 1)
    nextMonthEndDate = DateSerial(yearToSearch, monthToSearch + 2, 0)
    
    ' 日本の祝日を配列に格納します（必要に応じて更新してください）
    holidayDates = Array("01/01", "01/02", "01/03", "02/11", "03/20", "04/29", "05/03", "05/04", "05/05", "07/18", "08/11", "09/19", "09/23", "10/10", "11/03", "11/23", "12/23")
    
    ' データを転記します
    rowNum = 2 ' データを書き込む最初の行を設定します
    For Each currentDate In Array(prevMonthStartDate, startDate, nextMonthStartDate)
        ' 開始日から終了日までループします
        Do While currentDate <= IIf(rowNum = 3, prevMonthEndDate, endDate)
            ' もし土曜日または日曜日であれば、その日付と曜日を書き込みます
            If Weekday(currentDate) = vbSaturday Or Weekday(currentDate) = vbSunday Then
                ws.Cells(rowNum, 1).Value = Format(currentDate, "yyyy/mm/dd") ' 日付を書き込みます
                ws.Cells(rowNum, 2).Value = WeekdayName(Weekday(currentDate)) ' 曜日を書き込みます
                rowNum = rowNum + 1 ' 次の行に移動します
            End If
            
            ' 日本の祝日をチェックして、祝日であればその日付と曜日を書き込みます
            For i = LBound(holidayDates) To UBound(holidayDates)
                If Format(currentDate, "mm/dd") = holidayDates(i) Then
                    ws.Cells(rowNum, 1).Value = Format(currentDate, "yyyy/mm/dd") ' 日付を書き込みます
                    ws.Cells(rowNum, 2).Value = "Holiday" ' 曜日を"Holiday"と書き込みます
                    rowNum = rowNum + 1 ' 次の行に移動します
                End If
            Next i
            
            ' 次の日付に移動します
            currentDate = currentDate + 1
        Loop
    Next currentDate
End Sub

Sub TestExtractWeekendAndHolidayDatesByMonth()
    Dim yearToSearch As Integer
    Dim monthToSearch As Integer
    yearToSearch = InputBox("検索する年を入力してください", "年指定")
    monthToSearch = InputBox("検索する月を入力してください", "月指定")
    
    If IsNumeric(yearToSearch) And IsNumeric(monthToSearch) Then
        If monthToSearch >= 1 And monthToSearch <= 12 Then
            ExtractWeekendAndHolidayDatesByMonth yearToSearch, monthToSearch
        Else
            MsgBox "無効な月です。1から12までの数字を入力してください。"
        End If
    Else
        MsgBox "無効な入力です。数字を入力してください。"
    End If
End Sub

毎月の土曜日と日曜日 抽出

Sub ExtractWeekendDates()
    Dim startDate As Date
    Dim endDate As Date
    Dim currentDate As Date
    Dim ws As Worksheet
    Dim rowNum As Long
    
    ' 新しいシートを作成します
    Set ws = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
    ws.Name = "WeekendDates" ' シートの名前を設定します
    
    ' ヘッダーを設定します
    ws.Range("A1").Value = "Date"
    ws.Range("B1").Value = "Day"
    
    ' 開始日と終了日を設定します
    startDate = DateSerial(Year(Date), Month(Date), 1) ' 現在の月の1日を取得
    endDate = DateSerial(Year(Date), Month(Date) + 1, 0) ' 現在の月の最終日を取得
    
    ' データを転記します
    rowNum = 2 ' データを書き込む最初の行を設定します
    For currentDate = startDate To endDate
        ' もし土曜日または日曜日であれば、その日付と曜日を書き込みます
        If Weekday(currentDate) = vbSaturday Or Weekday(currentDate) = vbSunday Then
            ws.Cells(rowNum, 1).Value = Format(currentDate, "yyyy/mm/dd") ' 日付を書き込みます
            ws.Cells(rowNum, 2).Value = WeekdayName(Weekday(currentDate)) ' 曜日を書き込みます
            rowNum = rowNum + 1 ' 次の行に移動します
        End If
    Next currentDate
End Sub

日本の休日を考慮して土曜日と日曜日を検索

Sub ExtractWeekendAndHolidayDatesByYear(yearToSearch As Integer)
    Dim startDate As Date
    Dim endDate As Date
    Dim currentDate As Date
    Dim ws As Worksheet
    Dim rowNum As Long
    Dim holidayDates As Variant
    Dim i As Integer
    
    ' 新しいシートを作成します
    Set ws = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
    ws.Name = "WeekendAndHolidayDates" ' シートの名前を設定します
    
    ' ヘッダーを設定します
    ws.Range("A1").Value = "Date"
    ws.Range("B1").Value = "Day"
    
    ' 開始日と終了日を設定します
    startDate = DateSerial(yearToSearch, 1, 1) ' 指定された年の1月1日を取得
    endDate = DateSerial(yearToSearch, 12, 31) ' 指定された年の12月31日を取得
    
    ' 日本の祝日を配列に格納します（必要に応じて更新してください）
    holidayDates = Array("01/01", "01/02", "01/03", "02/11", "03/20", "04/29", "05/03", "05/04", "05/05", "07/18", "08/11", "09/19", "09/23", "10/10", "11/03", "11/23", "12/23")
    
    ' データを転記します
    rowNum = 2 ' データを書き込む最初の行を設定します
    For currentDate = startDate To endDate
        ' もし土曜日または日曜日であれば、その日付と曜日を書き込みます
        If Weekday(currentDate) = vbSaturday Or Weekday(currentDate) = vbSunday Then
            ws.Cells(rowNum, 1).Value = Format(currentDate, "yyyy/mm/dd") ' 日付を書き込みます
            ws.Cells(rowNum, 2).Value = WeekdayName(Weekday(currentDate)) ' 曜日を書き込みます
            rowNum = rowNum + 1 ' 次の行に移動します
        End If
        
        ' 日本の祝日をチェックして、祝日であればその日付と曜日を書き込みます
        For i = LBound(holidayDates) To UBound(holidayDates)
            If Format(currentDate, "mm/dd") = holidayDates(i) Then
                ws.Cells(rowNum, 1).Value = Format(currentDate, "yyyy/mm/dd") ' 日付を書き込みます
                ws.Cells(rowNum, 2).Value = "Holiday" ' 曜日を"Holiday"と書き込みます
                rowNum = rowNum + 1 ' 次の行に移動します
            End If
        Next i
    Next currentDate
End Sub

Sub TestExtractWeekendAndHolidayDatesByYear()
    Dim yearToSearch As Integer
    yearToSearch = InputBox("検索する年度を入力してください", "年度指定")
    If IsNumeric(yearToSearch) Then
        ExtractWeekendAndHolidayDatesByYear yearToSearch
    Else
        MsgBox "無効な入力です。数字を入力してください。"
    End If
End Sub

クリア (列全体 EntireColumn)

Sub Sample()
    Range("B2:D5").EntireColumn.Clear
End Sub

 

重複削除

Sub Sample()
    Range("A:C").RemoveDuplicates(Array(1, 2, 3))
End Sub

条件 振り分け2

Sub UpdateDColumnWithRegex555()
    Dim regex As Object
    Dim lastRow As Long
    Dim i As Long
    '参照設定  Microsoft VBScript Regular Expressions 5.5
    ' 正規表現オブジェクトを作成
    Set regex = CreateObject("VBScript.RegExp")
    
    ' パターンを設定
    regex.IgnoreCase = True
    regex.Global = True
    
    ' 最終行を取得
    lastRow = Cells(Rows.Count, "C").End(xlUp).Row
    
    ' ループして条件に基づいてD列を更新
    For i = 2 To lastRow
        ' 正規表現パターンに一致するかチェック
        If regexTest(regex, Cells(i, "C").Value, "Test.*Z.*") Then
            Cells(i, "D").Value = "test1"
        ElseIf regexTest(regex, Cells(i, "C").Value, "Test.*Y.*") Then
            Cells(i, "D").Value = "test1"
        ElseIf regexTest(regex, Cells(i, "C").Value, "Test.*X.*") Then
            Cells(i, "D").Value = "test2"
        ElseIf regexTest(regex, Cells(i, "C").Value, "Test.*") Then
            Cells(i, "D").Value = "test2"
        ElseIf regexTest(regex, Cells(i, "C").Value, "RRR.*") Then
            Cells(i, "D").Value = "test3"
        Else
            Cells(i, "D").Value = "test1"
        End If
    Next i
    
    ' 正規表現オブジェクトを解放
    Set regex = Nothing
End Sub
Function regexTest(regex As Object, str As String, pattern As String) As Boolean
    regex.pattern = pattern
    regexTest = regex.Test(str)
End Function

条件 振り分け

Sub UpdateDColumn()
    Dim lastRow As Long
    Dim i As Long
    
    ' 最終行を取得
    lastRow = Cells(Rows.Count, "C").End(xlUp).Row
    
    ' ループして条件に基づいてD列を更新
    For i = 2 To lastRow
        If InStr(1, Cells(i, "C").Value, "AAA") > 0 And InStr(1, Cells(i, "C").Value, "Z") > 0 Then
            Cells(i, "D").Value = "A111"
        ElseIf InStr(1, Cells(i, "C").Value, "BBB") > 0 And InStr(1, Cells(i, "C").Value, "X") > 0 Then
            Cells(i, "D").Value = "B222"
        ElseIf InStr(1, Cells(i, "C").Value, "CCC") > 0 Then
            Cells(i, "D").Value = "C333"
        Else
            Cells(i, "D").Value = "ZZZZ"
        End If
    Next i
End Sub