ひできちの楽天ブログ

 

Sub シート操作form()
UserForm1.Show vbModeless

End Sub
 

 'UserForm
Dim targetWb As Workbook
Dim targetPath As String

Private Sub CommandButton1_Click()

End Sub



Private Sub UserForm_Initialize()

Dim ws As Worksheet
Dim lastRow As Long
Dim i As Long
Dim colorName As String
Dim hexVal As String

'-----------------------------------------
' 見出し色定義シートの存在チェック
'-----------------------------------------
On Error Resume Next
Set ws = ThisWorkbook.Worksheets("見出し色定義")
On Error GoTo 0

' なければ作成
If ws Is Nothing Then
Set ws = ThisWorkbook.Worksheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
ws.name = "見出し色定義"

' 初期ヘッダー行
ws.Range("A1").Value = "色名"
ws.Range("B1").Value = "HEX"

' 必要なら初期色を入れておく（任意）
ws.Range("A2").Value = "赤"
ws.Range("B2").Value = "FF0000"

ws.Range("A3").Value = "青"
ws.Range("B3").Value = "0000FF"
End If


'-----------------------------------------
' シートから色名とHEXを読み込む
'-----------------------------------------
lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row

For i = 2 To lastRow   ' 1行目は見出し
colorName = Trim(ws.Cells(i, "A").Value)
hexVal = UCase$(Trim(ws.Cells(i, "B").Value))

' HEX は必ず6桁
If Len(hexVal) = 6 Then
Me.ListBox2.AddItem colorName
Me.ListBox2.List(Me.ListBox2.ListCount - 1, 1) = hexVal
End If
Next i


' --- コンボボックスに選択モードを追加 ---
With Me.cmbSelectMode
.Clear
.AddItem "単一選択"      ' MultiSelect = 0
.AddItem "複数選択"      ' MultiSelect = 1
.AddItem "拡張選択"      ' MultiSelect = 2
.ListIndex = 0           ' 初期値：単一選択
End With

End Sub



Private Sub cmdRefresh_Click()

If targetWb Is Nothing Then Exit Sub

' シート一覧を最新化
RefreshSheetList

' ついでに現在アクティブなシートを選択状態にする
Dim ws As Worksheet
Set ws = targetWb.ActiveSheet

Dim i As Long
For i = 0 To Me.ListBox1.ListCount - 1
If Me.ListBox1.List(i) = ws.name Then
Me.ListBox1.ListIndex = i
Exit For
End If
Next i

End Sub

Private Sub cmdOpenBook_Click()

Dim fd As FileDialog
Dim sh As Worksheet
Dim backupPath As String

' ファイル選択
Set fd = Application.FileDialog(msoFileDialogFilePicker)
With fd
.Title = "編集するブックを選択してください"
.Filters.Clear
.Filters.Add "Excel ブック", "*.xlsx; *.xlsm; *.xls"
If .Show <> -1 Then Exit Sub
targetPath = .SelectedItems(1)
End With

'    ' バックアップ作成（可逆性の確保）
'    backupPath = targetPath & ".bak_" & Format(Now, "yyyymmdd_hhnnss")
'    FileCopy targetPath, backupPath

' 書き込み可能で開く
Set targetWb = Workbooks.Open(Filename:=targetPath, ReadOnly:=False)

' ListBox 初期化
Me.ListBox1.Clear

' シート名を追加
For Each sh In targetWb.Worksheets
Me.ListBox1.AddItem sh.name
Next sh


End Sub



Private Sub RefreshSheetList()

Dim sh As Worksheet

Me.ListBox1.Clear
For Each sh In targetWb.Worksheets
Me.ListBox1.AddItem sh.name
Next sh

End Sub

Private Sub cmdCopySheet_Click()

Dim shName As String
Dim ws As Worksheet

If Me.ListBox1.ListIndex = -1 Then
MsgBox "シートを選択してください", vbExclamation
Exit Sub
End If

CopySelectedSheets

If chkSave.Value = True Then
' 自動保存
targetWb.Save
End If


End Sub

Private Sub cmdDown_Click()

Dim idx As Long
Dim ws As Worksheet
Dim last As Long

If Me.ListBox1.ListIndex = -1 Then
MsgBox "シートを選択してください", vbExclamation
Exit Sub
End If

MoveDown

If chkSave.Value = True Then
' 自動保存
targetWb.Save
End If



End Sub

Private Sub cmdRename_Click()

Dim idx As Long
Dim ws As Worksheet
Dim newName As String

If Me.ListBox1.ListIndex = -1 Then Exit Sub

idx = Me.ListBox1.ListIndex + 1
Set ws = targetWb.Worksheets(idx)

' InputBox で新しいシート名を取得
newName = InputBox("新しいシート名を入力してください", "シート名変更", ws.name)

' キャンセル or 空文字なら何もしない
If newName = "" Then Exit Sub

' シート名変更
On Error Resume Next
ws.name = newName
If Err Then
MsgBox "既に使用されている名前です", vbCritical + vbOKOnly
Exit Sub

End If

If chkSave.Value = True Then
' 自動保存
targetWb.Save
End If

' シート一覧更新
RefreshSheetList

' 変更後のシートを再選択
Me.ListBox1.ListIndex = idx - 1

End Sub

Private Sub cmdUp_Click()

Dim idx As Long
Dim ws As Worksheet

If Me.ListBox1.ListIndex = -1 Then
MsgBox "シートを選択してください", vbExclamation
Exit Sub
End If


MoveUp

If chkSave.Value = True Then
' 自動保存
targetWb.Save
End If



End Sub

Private Sub cmdCloseBook_Click()

' targetWb がセットされていなければ何もしない
If targetWb Is Nothing Then Exit Sub

' 保存して閉じる（保存不要なら Save を削除）
targetWb.Close SaveChanges:=True

' 参照を破棄
Set targetWb = Nothing

' フォームの表示内容をクリア
Me.ListBox1.Clear
Me.ListBox2.ListIndex = -1

' 必要なら他の UI も初期化
' 例：ラベルやテキストボックスを空にする
' Me.lblSheetName.Caption = ""

End Sub

Private Sub ListBox1_Change()

Dim idx As Long
Dim ws As Worksheet
Dim c As Variant
Dim hexVal As String
Dim i As Long
Dim found As Boolean

If targetWb Is Nothing Then Exit Sub
If Me.ListBox1.ListIndex = -1 Then Exit Sub

idx = Me.ListBox1.ListIndex + 1
Set ws = targetWb.Worksheets(idx)

ws.Activate

c = ws.Tab.Color

If IsNull(c) Then
Me.ListBox2.ListIndex = -1
Exit Sub
End If


hexVal = RGBToHex6(c)


found = False
For i = 0 To Me.ListBox2.ListCount - 1
If Me.ListBox2.List(i, 1) = hexVal Then   ' 2列目のHEXと比較
Me.ListBox2.ListIndex = i
found = True
Exit For
End If
Next i

If Not found Then
Me.ListBox2.AddItem hexVal
Me.ListBox2.List(Me.ListBox2.ListCount - 1, 1) = hexVal
Me.ListBox2.ListIndex = Me.ListBox2.ListCount - 1
End If

End Sub

Private Sub cmdColorChange_Click()

Dim idx As Long
Dim ws As Worksheet
Dim hexVal As String
Dim c As Long

If targetWb Is Nothing Then Exit Sub
If Me.ListBox1.ListIndex = -1 Then Exit Sub
If Me.ListBox2.ListIndex = -1 Then Exit Sub

hexVal = Me.ListBox2.List(Me.ListBox2.ListIndex, 1)
Call ChangeSheetColor(hexVal)

If chkSave.Value = True Then
' 自動保存
targetWb.Save
End If

End Sub

Private Sub cmbSelectMode_Change()

Select Case Me.cmbSelectMode.ListIndex
Case 0
Me.ListBox1.MultiSelect = 0   ' 単一選択
Case 1
Me.ListBox1.MultiSelect = 1   ' 複数選択（チェックボックス風）
Case 2
Me.ListBox1.MultiSelect = 2   ' 拡張選択（Ctrl/Shift）
End Select

End Sub

Private Function GetSelectedSheets() As Collection
Dim Col As New Collection
Dim i As Long

For i = 0 To Me.ListBox1.ListCount - 1
If Me.ListBox1.Selected(i) Then
Col.Add Me.ListBox1.List(i)
End If
Next i

Set GetSelectedSheets = Col
End Function


Private Function SetSelectedSheets(Col As Collection)
Dim n As String

For i = 0 To Me.ListBox1.ListCount - 1
n = ListBox1.List(i)
For j = 1 To Col.Count
If Col(j) = n Then
Me.ListBox1.Selected(i) = True

End If
Next
Next

End Function

Private Sub ChangeSheetColor(hexVal As String)

If targetWb Is Nothing Then Exit Sub

Dim Col As Collection
Dim name As Variant
Dim c As Long

Set Col = GetSelectedSheets()
If Col.Count = 0 Then Exit Sub

c = Hex6ToRGB(hexVal)

For Each name In Col
targetWb.Worksheets(name).Tab.Color = c
Next name

SetSelectedSheets Col


End Sub

Private Sub CopySelectedSheets()

If targetWb Is Nothing Then Exit Sub

Dim Col As Collection
Dim name As Variant

Set Col = GetSelectedSheets()
If Col.Count = 0 Then Exit Sub

For Each name In Col
targetWb.Worksheets(name).Copy After:=targetWb.Worksheets(name)
Next name
' シート一覧更新
RefreshSheetList

SetSelectedSheets Col

End Sub

Private Sub MoveUp()

If targetWb Is Nothing Then Exit Sub

Dim Col As Collection
Dim name As Variant
Dim ws As Worksheet

Set Col = GetSelectedSheets()
If Col.Count = 0 Then Exit Sub

Dim i As Long
For i = 1 To Col.Count
Set ws = targetWb.Worksheets(Col(i))
If ws.Index > 1 Then
ws.Move Before:=targetWb.Worksheets(ws.Index - 1)
End If
Next i

' シート一覧更新
RefreshSheetList

SetSelectedSheets Col

End Sub

Private Sub MoveDown()

If targetWb Is Nothing Then Exit Sub

Dim Col As Collection
Dim name As Variant
Dim ws As Worksheet

Set Col = GetSelectedSheets()
If Col.Count = 0 Then Exit Sub

Dim i As Long
For i = Col.Count To 1 Step -1
Set ws = targetWb.Worksheets(Col(i))
If ws.Index < targetWb.Worksheets.Count Then
ws.Move After:=targetWb.Worksheets(ws.Index + 1)
End If
Next i

' シート一覧更新
RefreshSheetList

SetSelectedSheets Col

End Sub

Private Function RGBToHex6(c As Variant) As String
Dim r As Long, g As Long, b As Long

r = c Mod 256
g = (c \ 256) Mod 256
b = (c \ 65536) Mod 256

RGBToHex6 = Right$("0" & Hex(r), 2) & Right$("0" & Hex(g), 2) & Right$("0" & Hex(b), 2)
End Function

Private Function Hex6ToRGB(hexStr As String) As Long
Dim r As Long, g As Long, b As Long

hexStr = Replace(hexStr, "#", "")
hexStr = UCase$(hexStr)

r = CLng("&H" & Mid$(hexStr, 1, 2))
g = CLng("&H" & Mid$(hexStr, 3, 2))
b = CLng("&H" & Mid$(hexStr, 5, 2))

Hex6ToRGB = RGB(r, g, b)
End Function