Excel VBA セル操作

Option Explicit
Option Base 1

Dim キー As String
Dim 前キー As String

Dim 処理行 As Long
Dim 最終行 As Long
Dim 属性 As String
Dim データ() As String
Dim 状況 As String
Dim 組合せ数 As Integer
Dim 検索行 As Integer

Private Sub 属性重複抽出()

   ThisWorkbook.Worksheets("データ").Activate
   最終行 = Cells(ActiveSheet.Rows.Count, 1).End(xlUp).Row

   For 処理行 = 1 To 最終行 + 1 'キーの変化を検出するため、一行余分に調べる

      状況 = ""
      キー = Range("A1").Cells(処理行, 1).Value
      
      If キー <> 前キー Then '直前行と比較して、キーのトップを検出
         Range("C1").Cells(処理行, 1).Value = "トップ"
         前属性 = 属性 'キーが変わったので、初期値を設定
         組合せ数 = 0
         Erase データ
      End If
      
      属性 = Range("B1").Cells(処理行, 1).Value
      If 属性 = "" Then GoTo 次の行へ
      
      組合せ数 = 組合せ数 + 1
      
      If 組合せ数 = 1 Then
         ReDim Preserve データ(組合せ数)
         データ(1) = 属性 '重複をチェックするため、配列に格納
         
      ElseIf 組合せ数 > 1 Then
      
         For 検索行 = 1 To 組合せ数 - 1 '登録済みの配列内容と照合して、合致したら重複として処置
             If データ(検索行) = 属性 Then
               Range("C1").Cells(処理行, 1).Value = "重複"
               組合せ数 = 組合せ数 - 1
               状況 = "重複"
               Exit For
             End If
         Next 検索行
         
         If 状況 = "" Then '重複していなければ、配列に格納
            ReDim Preserve データ(組合せ数)
            データ(組合せ数) = 属性
         End If
         
      End If
次の行へ:
   Next 処理行
End Sub

Option Explicit
Option Base 1

   Dim 最終行 As Long
   Dim 開始時刻 As Variant
   Dim 終了時刻 As Variant
   Dim 処理行 As Integer
   Dim コピー行数 As Integer
   Dim コピー元データ開始行 As Integer
   Dim コピー元ブック名 As String
   Dim コピー元シート名 As String
   Dim コピー元シート As Worksheet
   Dim 貼付け先ブック名 As String
   Dim 貼付け先シート名 As String
   Dim 貼付け先シート As Worksheet
   Dim 貼付け先データ開始行 As Integer
   Dim データ配列() As Variant
   Dim データ As Variant
   Dim コピー対象列 As String
   Dim 貼付け対象列 As String
   Dim コピー対象行数 As Integer
   Dim トリム処理 As Boolean
   Dim 型変換 As Integer
   Dim 配置 As Integer


Sub シートの指定列のデータを型変換してコピー()

   開始時刻 = Now()

   Call 処理指定とデータの読み込み

   Call 貼付け処理

   Set 貼付け先シート = Nothing

   終了時刻 = Now()

   MsgBox "処理が終了しました。" & Chr(13) & _
   "処理時間は、" & Format(終了時刻 - 開始時刻, "nn分ss秒") & " でした。", vbOKOnly
   
End Sub



Private Sub 貼付け処理()
   Dim 文字列 As String

   貼付け先シート.Activate
   For 処理行 = 1 To コピー対象行数
      If トリム処理 = True Then
         データ = Trim(データ配列(処理行, 1))
      Else
         データ = データ配列(処理行, 1)
      End If

      Select Case 型変換
         Case 1 '数値
            Range("A1").Cells(処理行 + 貼付け先データ開始行 - 1, 列番号(貼付け対象列)) _
               .NumberFormatLocal = "0_ "
         Case 2 '文字列
            Range("A1").Cells(処理行 + 貼付け先データ開始行 - 1, 列番号(貼付け対象列)) _
               .NumberFormatLocal = "@"
         Case 3 '日付：yyyymmdd
            Range("A1").Cells(処理行 + 貼付け先データ開始行 - 1, 列番号(貼付け対象列)) _
               .NumberFormatLocal = "yyyymmdd"
            文字列 = CStr(データ)
            文字列 = 正規表現で置換("([0-9]{4})([0-9]{2})([0-9]{2})", 文字列, "$1/$2/$3")
            データ = DateValue(文字列)

         Case 4 '日付：yyyy/mm/dd
            Range("A1").Cells(処理行 + 貼付け先データ開始行 - 1, 列番号(貼付け対象列)) _
               .NumberFormatLocal = "yyyy/mm/dd"
            データ = DateValue(データ)
      End Select

      Range("A1").Cells(処理行 + 貼付け先データ開始行 - 1, 列番号(貼付け対象列)) _
         .Value = データ


      Select Case 配置
         Case 1 '無指定

         Case 2 '左詰め
            Range("A1").Cells(処理行 + 貼付け先データ開始行 - 1, 列番号(貼付け対象列)) _
                 .HorizontalAlignment = xlLeft
         Case 3 '中央詰め
            Range("A1").Cells(処理行 + 貼付け先データ開始行 - 1, 列番号(貼付け対象列)) _
                 .HorizontalAlignment = xlCenter
         Case 4 '右詰め
            Range("A1").Cells(処理行 + 貼付け先データ開始行 - 1, 列番号(貼付け対象列)) _
                 .HorizontalAlignment = xlRight
      End Select

   Next 処理行
End Sub



Private Sub 処理指定とデータの読み込み()
   Dim キー列名 As String
   Dim 指定セル As Range

   ThisWorkbook.Worksheets("Sheet1").Activate

   コピー元ブック名 = Range("B7").Value
   コピー元シート名 = Range("B8").Value
   コピー元データ開始行 = Range("B9").Value
   コピー対象列 = Range("B11").Value

   貼付け先ブック名 = Range("C7").Value
   貼付け先シート名 = Range("C8").Value
   貼付け先データ開始行 = Range("C9").Value
   貼付け対象列 = Range("C11").Value

   If 貼付け先ブック名 = "" Then
      貼付け先ブック名 = コピー元ブック名
   End If

   If 貼付け先シート名 = "" Then
      貼付け先シート名 = コピー元シート名
   End If

   If 貼付け先データ開始行 = 0 Then
      貼付け先データ開始行 = コピー元データ開始行
   End If

   If 貼付け対象列 = "" Then
      貼付け対象列 = コピー対象列
   End If

   Set コピー元シート = Workbooks(コピー元ブック名).Worksheets(コピー元シート名)
   Set 貼付け先シート = Workbooks(貼付け先ブック名).Worksheets(貼付け先シート名)

   トリム処理 = Range("D11").Value
   型変換 = Range("E11").Value
   配置 = Range("G11").Value

   コピー元シート.Activate

   'コピー元シートから、対象データを配列に読み込む
   最終行 = Cells(ActiveSheet.Rows.Count, 列番号(コピー対象列)).End(xlUp).Row
   コピー対象行数 = 最終行 - コピー元データ開始行 + 1

   データ配列 = Range("A1").Cells(コピー元データ開始行, 列番号(コピー対象列)) _
      .Resize(コピー対象行数, 1).Value

   Set コピー元シート = Nothing

End Sub

Sub ファイル名として使えない禁止文字を消去()

   Dim 走査セル As Range
   Dim セルカウンタ As Long
   Dim 更新カウンタ As Integer
   Dim 更新前セル内容 As String
   Dim 更新後セル内容 As String
   Dim 使用不可文字配列 As Variant
   Dim 不可文字カウンタ As Integer
   Dim 更新対象 As Boolean
   
   '使用不可の文字を配列に代入
   使用不可文字配列 = Array("\", "/", ":", "*", "?", """", "<", ">", "|")
   
   セルカウンタ = 0
   更新カウンタ = 0
   
   ThisWorkbook.Worksheets("Sheet1").Range("A1").Activate
   
   For Each 走査セル In ActiveCell.CurrentRegion.Cells
'    セル範囲の各セルをループで操作する
'    https://docs.microsoft.com/ja-jp/office/vba/excel/concepts/cells-and-ranges/looping-through-a-range-of-cells

      セルカウンタ = セルカウンタ + 1
      更新対象 = False
      更新前セル内容 = 走査セル.Value
      更新後セル内容 = 更新前セル内容

      For 不可文字カウンタ = 1 To UBound(使用不可文字配列)
         If InStr(更新前セル内容, 使用不可文字配列(不可文字カウンタ)) > 0 Then
            更新対象 = True
            Exit For
         End If
      Next 不可文字カウンタ
      
      If InStr(更新前セル内容, ChrW(-3)) _
         Or InStr(更新前セル内容, ChrW(339)) > 0 Then
         更新対象 = True
      End If
      
      If 更新対象 = True Then

         更新後セル内容 = 不可文字削除(更新前セル内容)
      End If

      If 更新前セル内容 <> 更新後セル内容 Then

         走査セル.Value = 更新後セル内容
         更新カウンタ = 更新カウンタ + 1
'         MsgBox "更新セル数 = " & 更新カウンタ & vbNewLine _
'            & "更新前セル内容: " & 更新前セル内容 & vbNewLine _
'            & "更新後セル内容: " & 更新後セル内容
      End If
      
   Next
   
   MsgBox "処理を終了しました。" & vbNewLine _
      & "走査セル数 = " & セルカウンタ & vbNewLine _
      & "更新セル数 = " & 更新カウンタ

End Sub


Function 不可文字削除(ByVal 文字列 As String) As String
   '関数での String の受け渡しは、デフォルトは ByRef(参照渡し) です。
   'ByRef だと、変数「文字列」の値が関数の中で変更されると、
   '関数を参照している 不可文字削除(更新前セル内容) の変数「更新前セル内容」が、同時に変わってしまいます。
   'このため、せっかく関数で 文字列を変更しても、更新前セル内容 <> 更新後セル内容 にならない。
   'それで、明示的に ByVal としています。
   '関数の中で使う変数を、下のように「不可文字削除」とすれば、ByRef で「更新前セル内容」は変わりません。
   '関数の引数の変数名を、関数の中で使わないように注意しましょう。
   
   文字列 = Replace(文字列, vbTab, "")           'タブ削除
   文字列 = Replace(文字列, ":", "")       'コロン削除
   文字列 = Replace(文字列, "\", "")
   文字列 = Replace(文字列, "/", "")
   文字列 = Replace(文字列, "*", "")
   文字列 = Replace(文字列, """", "")
   文字列 = Replace(文字列, "<", "")
   文字列 = Replace(文字列, ">", "")
   文字列 = Replace(文字列, "|", "")
   文字列 = Replace(文字列, "[", "")
   文字列 = Replace(文字列, "]", "")
   文字列 = Replace(文字列, "?", "")       '? 削除
   文字列 = Replace(文字列, ChrW(-3), "")  'ChrW(65533))と同じ
   不可文字削除 = Replace(文字列, ChrW(339), "")
   
   '英数以外を除去
   '更新後セル内容 = RegularExpressions.Regex.Replace(txt, "[^0-9A-Za-z]", "")

End Function


'Function 不可文字削除(文字列 As String) As String
'   不可文字削除 = Replace(文字列, vbTab, "")           'タブ削除
'   不可文字削除 = Replace(不可文字削除, ":", "")       'コロン削除
'   不可文字削除 = Replace(不可文字削除, "\", "")
'   不可文字削除 = Replace(不可文字削除, "/", "")
'   不可文字削除 = Replace(不可文字削除, "*", "")
'   不可文字削除 = Replace(不可文字削除, """", "")
'   不可文字削除 = Replace(不可文字削除, "<", "")
'   不可文字削除 = Replace(不可文字削除, ">", "")
'   不可文字削除 = Replace(不可文字削除, "|", "")
'   不可文字削除 = Replace(不可文字削除, "[", "")
'   不可文字削除 = Replace(不可文字削除, "]", "")
'   不可文字削除 = Replace(不可文字削除, "?", "")       '? 削除
'   不可文字削除 = Replace(不可文字削除, ChrW(-3), "")  'ChrW(65533))と同じ
'   不可文字削除 = Replace(不可文字削除, ChrW(339), "")
'
'   '英数以外を除去
'   '更新後セル内容 = RegularExpressions.Regex.Replace(txt, "[^0-9A-Za-z]", "")
'
'End Function

Option Explicit

'02：2023/11/03：目標到達時点で色変え

Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
'これで Sleepを使ってミリ秒単位で処理にウェイトを入れることができます。

Dim 歩数 As Integer
Dim 上り As Integer
Dim 下り As Integer
Dim 現在のセル位地 As Range

'これだけはおさえるセル操作（1）−Offsetで自由自在
'https://www.moug.net/tech/exvba/0050057.html

Sub 階段昇降()
      
   'すべてのセルを空白に
   Worksheets("Sheet1").UsedRange.Clear
   歩数 = 0
   
   Do While 歩数 < 100
      For 上り = 1 To 3
         歩数 = 歩数 + 1
         If 歩数 = 1 Then
            Range("A1").Value = 歩数
            Range("A1").Interior.ColorIndex = 7
            Set 現在のセル位地 = Range("A1")
         Else
            Set 現在のセル位地 = 現在のセル位地.Offset(1, 1)
            現在のセル位地.Value = 歩数
            現在のセル位地.Interior.ColorIndex = 7
            If 現在のセル位地.Row = 16 Then
               Range("A1").Cells(現在のセル位地.Row).Resize(1, 現在のセル位地.Column - 1).Interior.ColorIndex = 8
               DoEvents       ' Sleep しているときに、画面を書き換えできるように、OS に制御を渡す。
               Sleep (2000)
            End If
         End If
         
      Next 上り
      
      DoEvents       ' Sleep しているときに、画面を書き換えできるように、OS に制御を渡す。
      Sleep (1000)
      
      For 下り = 1 To 2
         歩数 = 歩数 + 1
         Set 現在のセル位地 = 現在のセル位地.Offset(-1, 1)
         現在のセル位地.Value = 歩数
         現在のセル位地.Interior.ColorIndex = 4
'         Stop
      Next 下り

   Loop
   
   Set 現在のセル位地 = Nothing
   
   MsgBox "100歩 歩き終わりました！"

End Sub

Sub 初期化()
   'すべてのセルを空白に
   Worksheets("Sheet1").UsedRange.Clear
End Sub