Embedded Files
シート削除
シート削除
Sub DeleteSheetsByCondition() Dim ws As Worksheet Dim condition As String condition = "削除条件" ' 削除したいシート名の条件を設定 ' 警告メッセージを表示しない Application.DisplayAlerts = False ' すべてのシートをループ For Each ws In ThisWorkbook.Worksheets ' 条件に一致するシートを削除 If InStr(ws.Name, condition) > 0 Then ws.Delete End If Next ws ' 警告メッセージを再表示 Application.DisplayAlerts = TrueEnd Sub
フィルター
フィルター
Sub ClearAllFilters() Dim ws As Worksheet ' 対象のシートを設定 Set ws = ThisWorkbook.Sheets("Sheet1") ' フィルターが設定されているか確認 If ws.AutoFilterMode Then ' フィルターがかかっている場合、フィルターをクリア If ws.FilterMode Then ws.ShowAllData End If End IfEnd Sub
create文作成
create文作成
Sub シート_create文作成()
Dim s As Worksheet Dim r_end As Integer Dim i As Integer Dim w_str As String Set s = ActiveSheet With s.UsedRange r_end = .Row + .Rows.Count - 1 End With If s.Cells(2, 2).Value <> "Name" Then MsgBox "レイアウトが違います。" Exit Sub End If If Columns(1).Find("*") Is Nothing Then MsgBox "キーがありません。" Exit Sub End If
For i = 3 To r_end Select Case s.Cells(i, 3).Value Case "長整数型" s.Cells(i, 5).Value = "[int]" Case "テキスト型" s.Cells(i, 5).Value = "[varchar](" & s.Cells(i, 4).Value & ")" Case "整数型" s.Cells(i, 5).Value = "[smallint]"
Case "倍精度浮動小数点型" s.Cells(i, 5).Value = "[float]"
Case "Yes/No型" s.Cells(i, 5).Value = "[bit]"
Case "日付/時刻型" s.Cells(i, 5).Value = "[datetime]"
End Select
s.Cells(i, 6).Value = "w_str1 = w_str1 & """ & s.Cells(i, 2).Value & ","""
Next i w_str = "USE [KWT3KAGETU_TEST]" & vbLf w_str = w_str & "GO" & vbLf & vbLf w_str = w_str & "SET ANSI_NULLS ON" & vbLf w_str = w_str & "GO" & vbLf & vbLf w_str = w_str & "SET QUOTED_IDENTIFIER ON" & vbLf w_str = w_str & "GO" & vbLf & vbLf w_str = w_str & "CREATE TABLE [dbo].[" & s.Name & "](" & vbLf For i = 3 To r_end If s.Cells(i, 1).Value <> "" Then w_str = w_str & " [" & s.Cells(i, 2).Value & "] " & s.Cells(i, 5).Value & " NOT NULL," & vbLf Else w_str = w_str & " [" & s.Cells(i, 2).Value & "] " & s.Cells(i, 5).Value & " IDENTITY(1,1) NULL," & vbLf End If Next i w_str = w_str & " CONSTRAINT [PK_" & s.Name & "] PRIMARY KEY CLUSTERED " & vbLf w_str = w_str & "(" & vbLf For i = 3 To r_end If s.Cells(i, 1).Value <> "" Then w_str = w_str & " [" & s.Cells(i, 2).Value & "] ASC" & vbLf End If Next i w_str = w_str & ")WITH (PAD_INDEX = OFF, STATISTICS_NORECOMPUTE = OFF, IGNORE_DUP_KEY = OFF, ALLOW_ROW_LOCKS = ON, ALLOW_PAGE_LOCKS = ON) ON [PRIMARY]" & vbLf w_str = w_str & ") ON [PRIMARY]" & vbLf w_str = w_str & "GO"
ActiveSheet.Shapes.SelectAll On Error GoTo l_001 If Selection.ShapeRange.Count > 0 Then Selection.Delete End Ifl_001: On Error GoTo 0 'AddShape (型、 左、 上、 幅、 高さ) With ActiveSheet.Shapes.AddShape(msoShapeRectangle, 600, 50, 700, 1500) With .TextFrame.Characters .Text = w_str .Font.Size = 8 End With
With .TextFrame2.TextRange.Font.Fill .Visible = msoTrue .ForeColor.ObjectThemeColor = msoThemeColorText1 .ForeColor.TintAndShade = 0 .ForeColor.Brightness = 0 .Transparency = 0 .Solid End With
End With
End Sub
Dim s As Worksheet Dim r_end As Integer Dim i As Integer Dim w_str As String Set s = ActiveSheet With s.UsedRange r_end = .Row + .Rows.Count - 1 End With If s.Cells(2, 2).Value <> "Name" Then MsgBox "レイアウトが違います。" Exit Sub End If If Columns(1).Find("*") Is Nothing Then MsgBox "キーがありません。" Exit Sub End If
For i = 3 To r_end Select Case s.Cells(i, 3).Value Case "長整数型" s.Cells(i, 5).Value = "[int]" Case "テキスト型" s.Cells(i, 5).Value = "[varchar](" & s.Cells(i, 4).Value & ")" Case "整数型" s.Cells(i, 5).Value = "[smallint]"
Case "倍精度浮動小数点型" s.Cells(i, 5).Value = "[float]"
Case "Yes/No型" s.Cells(i, 5).Value = "[bit]"
Case "日付/時刻型" s.Cells(i, 5).Value = "[datetime]"
End Select
s.Cells(i, 6).Value = "w_str1 = w_str1 & """ & s.Cells(i, 2).Value & ","""
Next i w_str = "USE [KWT3KAGETU_TEST]" & vbLf w_str = w_str & "GO" & vbLf & vbLf w_str = w_str & "SET ANSI_NULLS ON" & vbLf w_str = w_str & "GO" & vbLf & vbLf w_str = w_str & "SET QUOTED_IDENTIFIER ON" & vbLf w_str = w_str & "GO" & vbLf & vbLf w_str = w_str & "CREATE TABLE [dbo].[" & s.Name & "](" & vbLf For i = 3 To r_end If s.Cells(i, 1).Value <> "" Then w_str = w_str & " [" & s.Cells(i, 2).Value & "] " & s.Cells(i, 5).Value & " NOT NULL," & vbLf Else w_str = w_str & " [" & s.Cells(i, 2).Value & "] " & s.Cells(i, 5).Value & " IDENTITY(1,1) NULL," & vbLf End If Next i w_str = w_str & " CONSTRAINT [PK_" & s.Name & "] PRIMARY KEY CLUSTERED " & vbLf w_str = w_str & "(" & vbLf For i = 3 To r_end If s.Cells(i, 1).Value <> "" Then w_str = w_str & " [" & s.Cells(i, 2).Value & "] ASC" & vbLf End If Next i w_str = w_str & ")WITH (PAD_INDEX = OFF, STATISTICS_NORECOMPUTE = OFF, IGNORE_DUP_KEY = OFF, ALLOW_ROW_LOCKS = ON, ALLOW_PAGE_LOCKS = ON) ON [PRIMARY]" & vbLf w_str = w_str & ") ON [PRIMARY]" & vbLf w_str = w_str & "GO"
ActiveSheet.Shapes.SelectAll On Error GoTo l_001 If Selection.ShapeRange.Count > 0 Then Selection.Delete End Ifl_001: On Error GoTo 0 'AddShape (型、 左、 上、 幅、 高さ) With ActiveSheet.Shapes.AddShape(msoShapeRectangle, 600, 50, 700, 1500) With .TextFrame.Characters .Text = w_str .Font.Size = 8 End With
With .TextFrame2.TextRange.Font.Fill .Visible = msoTrue .ForeColor.ObjectThemeColor = msoThemeColorText1 .ForeColor.TintAndShade = 0 .ForeColor.Brightness = 0 .Transparency = 0 .Solid End With
End With
End Sub
データベース構造の解析_フォーム
データベース構造の解析_フォーム
Sub シート_データベース構造の解析_フォーム()
'データベース構造の解析を編集する。 Dim s As Worksheet Dim r_end As Integer Dim i As Integer Dim i1 As Integer Dim w_int As Integer Dim w_int1 As Integer Dim w_int2 As Integer Dim w_str As String Dim w_str1 As String Set s = ActiveSheet With s.UsedRange r_end = .Row + .Rows.Count - 1 End With Cells.Interior.Pattern = xlNone
Application.ScreenUpdating = False For i = r_end To 2 Step -1 If s.Cells(i, 1).Value = "" Then s.Cells(i, 1).Delete End If Next i Application.ScreenUpdating = True s.Cells(1, 1).Value = "s" w_str1 = "" For i = 1 To r_end w_int = InStr(1, s.Cells(i, 1).Value, "フォーム:") If w_int > 0 Then w_str = Trim(Mid(s.Cells(i, 1).Value, w_int + 6, 30)) If w_str <> w_str1 Then s.Cells(i, 1).Interior.ColorIndex = 6 s.Cells(i, 3).Value = Trim(Mid(s.Cells(i, 1).Value, w_int + 6, 30)) w_str1 = s.Cells(i, 3).Value i1 = i End If End If
w_int = InStr(1, s.Cells(i, 1).Value, "Description:") If w_int > 0 Then s.Cells(i1, 2).Value = Trim(Mid(s.Cells(i, 1).Value, w_int + 32, 30)) End If
w_int = InStr(1, s.Cells(i, 1).Value, "Caption:") If w_int > 0 Then s.Cells(i1, 4).Value = Trim(Mid(s.Cells(i, 1).Value, w_int + 32, 30)) End If
w_int = InStr(1, s.Cells(i, 1).Value, "LastUpdated:") If w_int > 0 Then s.Cells(i1, 5).Value = Trim(Mid(s.Cells(i, 1).Value, w_int + 32, 30)) End If
Next i
For i = 1 To r_end If s.Cells(i, 1).Interior.ColorIndex = 6 Then If s.Cells(i, 2).Value = "" Then s.Cells(i, 2).Value = "'－" End If End If Next i Cells(1, 2).Value = "Description" Cells(1, 3).Value = "フォーム" Cells(1, 4).Value = "Caption" Cells(1, 5).Value = "LastUpdated" Cells.Font.name = "ＭＳ ゴシック" If ActiveSheet.AutoFilterMode Then Cells.AutoFilter End If Cells.AutoFilter Rows("2:2").Select ActiveWindow.FreezePanes = True Cells.EntireColumn.AutoFit Cells(1, 1).Select
End Sub
'データベース構造の解析を編集する。 Dim s As Worksheet Dim r_end As Integer Dim i As Integer Dim i1 As Integer Dim w_int As Integer Dim w_int1 As Integer Dim w_int2 As Integer Dim w_str As String Dim w_str1 As String Set s = ActiveSheet With s.UsedRange r_end = .Row + .Rows.Count - 1 End With Cells.Interior.Pattern = xlNone
Application.ScreenUpdating = False For i = r_end To 2 Step -1 If s.Cells(i, 1).Value = "" Then s.Cells(i, 1).Delete End If Next i Application.ScreenUpdating = True s.Cells(1, 1).Value = "s" w_str1 = "" For i = 1 To r_end w_int = InStr(1, s.Cells(i, 1).Value, "フォーム:") If w_int > 0 Then w_str = Trim(Mid(s.Cells(i, 1).Value, w_int + 6, 30)) If w_str <> w_str1 Then s.Cells(i, 1).Interior.ColorIndex = 6 s.Cells(i, 3).Value = Trim(Mid(s.Cells(i, 1).Value, w_int + 6, 30)) w_str1 = s.Cells(i, 3).Value i1 = i End If End If
w_int = InStr(1, s.Cells(i, 1).Value, "Description:") If w_int > 0 Then s.Cells(i1, 2).Value = Trim(Mid(s.Cells(i, 1).Value, w_int + 32, 30)) End If
w_int = InStr(1, s.Cells(i, 1).Value, "Caption:") If w_int > 0 Then s.Cells(i1, 4).Value = Trim(Mid(s.Cells(i, 1).Value, w_int + 32, 30)) End If
w_int = InStr(1, s.Cells(i, 1).Value, "LastUpdated:") If w_int > 0 Then s.Cells(i1, 5).Value = Trim(Mid(s.Cells(i, 1).Value, w_int + 32, 30)) End If
Next i
For i = 1 To r_end If s.Cells(i, 1).Interior.ColorIndex = 6 Then If s.Cells(i, 2).Value = "" Then s.Cells(i, 2).Value = "'－" End If End If Next i Cells(1, 2).Value = "Description" Cells(1, 3).Value = "フォーム" Cells(1, 4).Value = "Caption" Cells(1, 5).Value = "LastUpdated" Cells.Font.name = "ＭＳ ゴシック" If ActiveSheet.AutoFilterMode Then Cells.AutoFilter End If Cells.AutoFilter Rows("2:2").Select ActiveWindow.FreezePanes = True Cells.EntireColumn.AutoFit Cells(1, 1).Select
End Sub
データベース構造の解析_フィールドの情報
データベース構造の解析_フィールドの情報
Sub シート_データベース構造の解析_フィールドの情報()
'データベース構造の解析のフィールドの情報を編集する。 Dim s As Worksheet Dim r_end As Integer Dim i As Integer Dim i1 As Integer Dim w_int As Integer Dim w_テーブル As String Set s = ActiveSheet With s.UsedRange r_end = .Row + .Rows.Count - 1 End With
For i = 1 To r_end w_int = InStr(1, s.Cells(i, 1), "テーブル: ") If w_int > 0 Then w_テーブル = Trim(MidB(s.Cells(i, 1).Value, 11, 40)) End If If Trim(Left(s.Cells(i, 1).Value, 11)) = "" And Trim(Mid(s.Cells(i, 1).Value, 12, 1)) <> "" Then If Mid(s.Cells(i, 1).Value, 12, 6) <> "フィールド名" Then s.Cells(i, 1).Interior.ColorIndex = 6 s.Cells(i, 2).Value = w_テーブル s.Cells(i, 5).Value = Trim(Mid(s.Cells(i, 1).Value, 12, 20)) s.Cells(i, 8).Value = Trim(Mid(s.Cells(i, 1).Value, 78, 20)) s.Cells(i, 9).Value = Trim(Right(s.Cells(i, 1).Value, 10)) i1 = i End If End If w_int = InStr(1, s.Cells(i, 1), "Caption:") If w_int > 0 Then s.Cells(i1, 3).Value = Trim(Mid(s.Cells(i, 1).Value, 56, 20)) End If w_int = InStr(1, s.Cells(i, 1), "Required:") If w_int > 0 Then If Trim(Mid(s.Cells(i, 1).Value, 56, 20)) = "True" Then s.Cells(i1, 7).Value = "P" End If s.Cells(i1, 10).Value = Trim(Mid(s.Cells(i, 1).Value, 56, 20)) End If w_int = InStr(1, s.Cells(i, 1), "Description:") If w_int > 0 Then s.Cells(i1, 11).Value = Trim(Mid(s.Cells(i, 1).Value, 56, 99)) End If Next i
For i = 1 To r_end
If s.Cells(i, 1).Interior.ColorIndex = 6 Then If s.Cells(i, 3).Value = "" Then s.Cells(i, 3).Value = "'－" End If End If Next i s.Columns("B:K").ColumnWidth = 2 s.Columns("B:K").EntireColumn.AutoFit
End Sub
'データベース構造の解析のフィールドの情報を編集する。 Dim s As Worksheet Dim r_end As Integer Dim i As Integer Dim i1 As Integer Dim w_int As Integer Dim w_テーブル As String Set s = ActiveSheet With s.UsedRange r_end = .Row + .Rows.Count - 1 End With
For i = 1 To r_end w_int = InStr(1, s.Cells(i, 1), "テーブル: ") If w_int > 0 Then w_テーブル = Trim(MidB(s.Cells(i, 1).Value, 11, 40)) End If If Trim(Left(s.Cells(i, 1).Value, 11)) = "" And Trim(Mid(s.Cells(i, 1).Value, 12, 1)) <> "" Then If Mid(s.Cells(i, 1).Value, 12, 6) <> "フィールド名" Then s.Cells(i, 1).Interior.ColorIndex = 6 s.Cells(i, 2).Value = w_テーブル s.Cells(i, 5).Value = Trim(Mid(s.Cells(i, 1).Value, 12, 20)) s.Cells(i, 8).Value = Trim(Mid(s.Cells(i, 1).Value, 78, 20)) s.Cells(i, 9).Value = Trim(Right(s.Cells(i, 1).Value, 10)) i1 = i End If End If w_int = InStr(1, s.Cells(i, 1), "Caption:") If w_int > 0 Then s.Cells(i1, 3).Value = Trim(Mid(s.Cells(i, 1).Value, 56, 20)) End If w_int = InStr(1, s.Cells(i, 1), "Required:") If w_int > 0 Then If Trim(Mid(s.Cells(i, 1).Value, 56, 20)) = "True" Then s.Cells(i1, 7).Value = "P" End If s.Cells(i1, 10).Value = Trim(Mid(s.Cells(i, 1).Value, 56, 20)) End If w_int = InStr(1, s.Cells(i, 1), "Description:") If w_int > 0 Then s.Cells(i1, 11).Value = Trim(Mid(s.Cells(i, 1).Value, 56, 99)) End If Next i
For i = 1 To r_end
If s.Cells(i, 1).Interior.ColorIndex = 6 Then If s.Cells(i, 3).Value = "" Then s.Cells(i, 3).Value = "'－" End If End If Next i s.Columns("B:K").ColumnWidth = 2 s.Columns("B:K").EntireColumn.AutoFit
End Sub
データベース構造の解析_テーブル
データベース構造の解析_テーブル
Sub シート_データベース構造の解析_テーブル()
'データベース構造の解析を編集する。 Dim s As Worksheet Dim r_end As Integer Dim i As Integer Dim i1 As Integer Dim w_int As Integer Dim w_int1 As Integer Dim w_int2 As Integer Dim w_str As String Set s = ActiveSheet With s.UsedRange r_end = .Row + .Rows.Count - 1 End With
Application.ScreenUpdating = False For i = r_end To 2 Step -1 If s.Cells(i, 1).Value = "" Then s.Cells(i, 1).Delete End If Next i Application.ScreenUpdating = True s.Cells(1, 1).Value = "s" For i = 1 To r_end w_int = InStr(1, s.Cells(i, 1).Value, "テーブル:") If w_int > 0 Then s.Cells(i, 1).Interior.ColorIndex = 6 s.Cells(i, 3).Value = Trim(Mid(s.Cells(i, 1).Value, w_int + 6, 30)) i1 = i End If w_int = InStr(1, s.Cells(i, 1).Value, "Description:") If w_int > 0 Then s.Cells(i1, 2).Value = Trim(Mid(s.Cells(i, 1).Value, w_int + 32, 30)) End If w_int = InStr(1, s.Cells(i, 1).Value, "LastUpdated:") If w_int > 0 Then s.Cells(i1, 4).Value = Trim(Mid(s.Cells(i, 1).Value, w_int + 32, 30)) End If w_int = InStr(1, s.Cells(i, 1).Value, ";DATABASE=") If w_int > 0 Then w_int = w_int + 10 w_int1 = InStr(w_int, s.Cells(i, 1).Value, " ") If w_int1 = 0 Then w_int1 = Len(s.Cells(i, 1).Value) End If w_str = Trim(s.Cells(i + 1, 1).Value) w_int2 = InStr(1, w_str, " ") If w_int2 = 0 Then w_int2 = Len(w_str) Else w_int2 = w_int2 - 1 End If w_str = Left(w_str, w_int2) s.Cells(i1, 5).Value = Trim(Mid(s.Cells(i, 1).Value, w_int, w_int1 - w_int)) & w_str End If Next i
For i = 1 To r_end If s.Cells(i, 1).Interior.ColorIndex = 6 Then If s.Cells(i, 2).Value = "" Then s.Cells(i, 2).Value = "'－" End If End If Next i Cells.Font.name = "ＭＳ ゴシック" Cells.AutoFilter Rows("2:2").Select ActiveWindow.FreezePanes = True Cells.EntireColumn.AutoFit
End Sub
'データベース構造の解析を編集する。 Dim s As Worksheet Dim r_end As Integer Dim i As Integer Dim i1 As Integer Dim w_int As Integer Dim w_int1 As Integer Dim w_int2 As Integer Dim w_str As String Set s = ActiveSheet With s.UsedRange r_end = .Row + .Rows.Count - 1 End With
Application.ScreenUpdating = False For i = r_end To 2 Step -1 If s.Cells(i, 1).Value = "" Then s.Cells(i, 1).Delete End If Next i Application.ScreenUpdating = True s.Cells(1, 1).Value = "s" For i = 1 To r_end w_int = InStr(1, s.Cells(i, 1).Value, "テーブル:") If w_int > 0 Then s.Cells(i, 1).Interior.ColorIndex = 6 s.Cells(i, 3).Value = Trim(Mid(s.Cells(i, 1).Value, w_int + 6, 30)) i1 = i End If w_int = InStr(1, s.Cells(i, 1).Value, "Description:") If w_int > 0 Then s.Cells(i1, 2).Value = Trim(Mid(s.Cells(i, 1).Value, w_int + 32, 30)) End If w_int = InStr(1, s.Cells(i, 1).Value, "LastUpdated:") If w_int > 0 Then s.Cells(i1, 4).Value = Trim(Mid(s.Cells(i, 1).Value, w_int + 32, 30)) End If w_int = InStr(1, s.Cells(i, 1).Value, ";DATABASE=") If w_int > 0 Then w_int = w_int + 10 w_int1 = InStr(w_int, s.Cells(i, 1).Value, " ") If w_int1 = 0 Then w_int1 = Len(s.Cells(i, 1).Value) End If w_str = Trim(s.Cells(i + 1, 1).Value) w_int2 = InStr(1, w_str, " ") If w_int2 = 0 Then w_int2 = Len(w_str) Else w_int2 = w_int2 - 1 End If w_str = Left(w_str, w_int2) s.Cells(i1, 5).Value = Trim(Mid(s.Cells(i, 1).Value, w_int, w_int1 - w_int)) & w_str End If Next i
For i = 1 To r_end If s.Cells(i, 1).Interior.ColorIndex = 6 Then If s.Cells(i, 2).Value = "" Then s.Cells(i, 2).Value = "'－" End If End If Next i Cells.Font.name = "ＭＳ ゴシック" Cells.AutoFilter Rows("2:2").Select ActiveWindow.FreezePanes = True Cells.EntireColumn.AutoFit
End Sub
ナレッジ用作成
ナレッジ用作成
Sub シート_ナレッジ用作成()
Dim w_ActiveCell As Range Dim w_range As Range
Set w_ActiveCell = ActiveCell
Cells.ColumnWidth = 2 Cells.NumberFormatLocal = "G/標準" Cells.Font.name = "HGｺﾞｼｯｸM" Columns("A:A").Select With Selection .HorizontalAlignment = xlCenter .VerticalAlignment = xlTop .WrapText = False .Orientation = 0 .AddIndent = False .IndentLevel = 0 .ShrinkToFit = False .ReadingOrder = xlContext .MergeCells = False End With Selection.NumberFormatLocal = "@" Range("A1").HorizontalAlignment = xlGeneral Columns("B:B").Select With Selection .HorizontalAlignment = xlGeneral .VerticalAlignment = xlTop .WrapText = True .Orientation = 0 .AddIndent = False .IndentLevel = 0 .ShrinkToFit = False .ReadingOrder = xlContext End With Selection.NumberFormatLocal = "@" Range("B1").Select Selection.ColumnWidth = 100 Columns("C:C").Select With Selection .HorizontalAlignment = xlGeneral .VerticalAlignment = xlTop .WrapText = False .Orientation = 0 .AddIndent = False .IndentLevel = 0 .ShrinkToFit = False .ReadingOrder = xlContext End With Selection.NumberFormatLocal = "@" Range("C1").Select Selection.ColumnWidth = 100 Rows("1:1").Select With Selection.Interior .Pattern = xlSolid .PatternColorIndex = xlAutomatic .Color = 12611584 '青 .TintAndShade = 0 .PatternTintAndShade = 0 End With With Selection.Font .ThemeColor = xlThemeColorDark1 .TintAndShade = 0 End With
ActiveWindow.FreezePanes = False Range("3:3").Activate ActiveWindow.FreezePanes = True
Cells.VerticalAlignment = xlTop If Range("A1") = "" Or Range("A1") = "INDEX" Or Range("A1") = "※" Then Range("A1").Select ActiveCell.FormulaR1C1 = "※" ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:="", SubAddress:="INDEX!A1", TextToDisplay:="※" With Selection.Font .ThemeColor = xlThemeColorDark1 .TintAndShade = 0 End With End If Range("A1").TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _ TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _ Semicolon:=False, Comma:=False, Space:=False, Other:=False, FieldInfo _ :=Array(1, 1), TrailingMinusNumbers:=True If ActiveSheet.AutoFilterMode Then Selection.AutoFilter End If If Range("A2").Value = "(LINK)" Then Range("A2").Value = "" End If ActiveSheet.Cells.Select On Error Resume Next Selection.AutoFilter On Error GoTo 0 Columns(1).AutoFit Selection.AutoFilter w_ActiveCell.Select Application.StatusBar = False
End Sub
Dim w_ActiveCell As Range Dim w_range As Range
Set w_ActiveCell = ActiveCell
Cells.ColumnWidth = 2 Cells.NumberFormatLocal = "G/標準" Cells.Font.name = "HGｺﾞｼｯｸM" Columns("A:A").Select With Selection .HorizontalAlignment = xlCenter .VerticalAlignment = xlTop .WrapText = False .Orientation = 0 .AddIndent = False .IndentLevel = 0 .ShrinkToFit = False .ReadingOrder = xlContext .MergeCells = False End With Selection.NumberFormatLocal = "@" Range("A1").HorizontalAlignment = xlGeneral Columns("B:B").Select With Selection .HorizontalAlignment = xlGeneral .VerticalAlignment = xlTop .WrapText = True .Orientation = 0 .AddIndent = False .IndentLevel = 0 .ShrinkToFit = False .ReadingOrder = xlContext End With Selection.NumberFormatLocal = "@" Range("B1").Select Selection.ColumnWidth = 100 Columns("C:C").Select With Selection .HorizontalAlignment = xlGeneral .VerticalAlignment = xlTop .WrapText = False .Orientation = 0 .AddIndent = False .IndentLevel = 0 .ShrinkToFit = False .ReadingOrder = xlContext End With Selection.NumberFormatLocal = "@" Range("C1").Select Selection.ColumnWidth = 100 Rows("1:1").Select With Selection.Interior .Pattern = xlSolid .PatternColorIndex = xlAutomatic .Color = 12611584 '青 .TintAndShade = 0 .PatternTintAndShade = 0 End With With Selection.Font .ThemeColor = xlThemeColorDark1 .TintAndShade = 0 End With
ActiveWindow.FreezePanes = False Range("3:3").Activate ActiveWindow.FreezePanes = True
Cells.VerticalAlignment = xlTop If Range("A1") = "" Or Range("A1") = "INDEX" Or Range("A1") = "※" Then Range("A1").Select ActiveCell.FormulaR1C1 = "※" ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:="", SubAddress:="INDEX!A1", TextToDisplay:="※" With Selection.Font .ThemeColor = xlThemeColorDark1 .TintAndShade = 0 End With End If Range("A1").TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _ TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _ Semicolon:=False, Comma:=False, Space:=False, Other:=False, FieldInfo _ :=Array(1, 1), TrailingMinusNumbers:=True If ActiveSheet.AutoFilterMode Then Selection.AutoFilter End If If Range("A2").Value = "(LINK)" Then Range("A2").Value = "" End If ActiveSheet.Cells.Select On Error Resume Next Selection.AutoFilter On Error GoTo 0 Columns(1).AutoFit Selection.AutoFilter w_ActiveCell.Select Application.StatusBar = False
End Sub
ページ設定
ページ設定
Sub シート_ページ設定() With ActiveSheet.PageSetup .Zoom = False .FitToPagesWide = 1 .FitToPagesTall = 1 End With
End Sub
End Sub
区切り位置なし
区切り位置なし
Sub シート_区切り位置なし()
'区切り位置無しに設定
Dim w_range As Range Set w_range = ActiveCell
If Range("A1") = "" Then Range("A1") = "xxx" End If Range("A1").Select Selection.TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, TextQualifier:=xlDoubleQuote, _ ConsecutiveDelimiter:=False, Tab:=False, Semicolon:=False, Comma:=False, Space:=False, _ Other:=False, FieldInfo:=Array(1, 2), TrailingMinusNumbers:=True
If Range("A1") = "xxx" Then Range("A1") = "" End If
Cells.NumberFormatLocal = "@" w_range.Activate
End Sub
'区切り位置無しに設定
Dim w_range As Range Set w_range = ActiveCell
If Range("A1") = "" Then Range("A1") = "xxx" End If Range("A1").Select Selection.TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, TextQualifier:=xlDoubleQuote, _ ConsecutiveDelimiter:=False, Tab:=False, Semicolon:=False, Comma:=False, Space:=False, _ Other:=False, FieldInfo:=Array(1, 2), TrailingMinusNumbers:=True
If Range("A1") = "xxx" Then Range("A1") = "" End If
Cells.NumberFormatLocal = "@" w_range.Activate
End Sub
テーブル化
テーブル化
Sub シート_テーブル化()
Dim w_range As Range Dim w_str As String On Error Resume Next ActiveSheet.ListObjects(1).Unlist On Error GoTo 0 If Selection.Rows.Count = 1 And Selection.Columns.Count = 1 Then ActiveSheet.UsedRange.Select Cells.ColumnWidth = 2 ElseIf Selection.Rows.Count > ActiveSheet.UsedRange.Rows.Count Or Selection.Columns.Count > ActiveSheet.UsedRange.Columns.Count Then ActiveSheet.UsedRange.Select Cells.ColumnWidth = 2 End If If Selection(1).Value = "" Then Selection(1).Value = "AAA" End If With Selection.Interior .Pattern = xlNone .TintAndShade = 0 .PatternTintAndShade = 0 End With With Selection.Font .Size = 12 End With Selection.Font.Bold = False With Selection.Font .Size = 12 End With Selection.Borders(xlDiagonalDown).LineStyle = xlNone Selection.Borders(xlDiagonalUp).LineStyle = xlNone Selection.Borders(xlEdgeLeft).LineStyle = xlNone Selection.Borders(xlEdgeTop).LineStyle = xlNone Selection.Borders(xlEdgeBottom).LineStyle = xlNone Selection.Borders(xlEdgeRight).LineStyle = xlNone Selection.Borders(xlInsideVertical).LineStyle = xlNone Selection.Borders(xlInsideHorizontal).LineStyle = xlNone w_str = "t_" & ActiveSheet.name ActiveSheet.ListObjects.Add(xlSrcRange, Selection, , xlYes).name = w_str ActiveSheet.ListObjects(w_str).TableStyle = "TableStyleMedium13"
Range(w_str).Select With Selection .HorizontalAlignment = xlGeneral .VerticalAlignment = xlTop .Orientation = 0 .AddIndent = False .IndentLevel = 0 .ShrinkToFit = False .ReadingOrder = xlContext .MergeCells = False End With With Rows("1:1") .HorizontalAlignment = xlLeft .VerticalAlignment = xlTop .WrapText = False If ActiveSheet.ListObjects(w_str).ListColumns.Count > 20 Then .Orientation = xlVertical End If .AddIndent = False .IndentLevel = 0 .ShrinkToFit = False .ReadingOrder = xlContext .MergeCells = False End With
Range(w_str & "[#All]").Select Selection.ColumnWidth = 50 Selection.Columns.AutoFit Selection.Rows.AutoFit For Each w_range In ActiveSheet.ListObjects(w_str).HeaderRowRange Select Case w_range.Value Case "日付", "作成日", "更新日" w_range.EntireColumn.NumberFormatLocal = "yyyy-mm-dd;@" w_range.EntireColumn.AutoFit ActiveSheet.DisplayPageBreaks = False End Select Next w_range On Error GoTo l_wnd Range("t_時間集計[#Headers]").Select With Selection .HorizontalAlignment = xlLeft .VerticalAlignment = xlTop .WrapText = False .Orientation = xlVertical .AddIndent = False .IndentLevel = 0 .ShrinkToFit = False .ReadingOrder = xlContext .MergeCells = False End With Range("t_時間集計[#All]").Select Selection.Columns.AutoFit l_end: Rows("2:2").Select ActiveWindow.FreezePanes = True Range("A1").Select
End Sub
Dim w_range As Range Dim w_str As String On Error Resume Next ActiveSheet.ListObjects(1).Unlist On Error GoTo 0 If Selection.Rows.Count = 1 And Selection.Columns.Count = 1 Then ActiveSheet.UsedRange.Select Cells.ColumnWidth = 2 ElseIf Selection.Rows.Count > ActiveSheet.UsedRange.Rows.Count Or Selection.Columns.Count > ActiveSheet.UsedRange.Columns.Count Then ActiveSheet.UsedRange.Select Cells.ColumnWidth = 2 End If If Selection(1).Value = "" Then Selection(1).Value = "AAA" End If With Selection.Interior .Pattern = xlNone .TintAndShade = 0 .PatternTintAndShade = 0 End With With Selection.Font .Size = 12 End With Selection.Font.Bold = False With Selection.Font .Size = 12 End With Selection.Borders(xlDiagonalDown).LineStyle = xlNone Selection.Borders(xlDiagonalUp).LineStyle = xlNone Selection.Borders(xlEdgeLeft).LineStyle = xlNone Selection.Borders(xlEdgeTop).LineStyle = xlNone Selection.Borders(xlEdgeBottom).LineStyle = xlNone Selection.Borders(xlEdgeRight).LineStyle = xlNone Selection.Borders(xlInsideVertical).LineStyle = xlNone Selection.Borders(xlInsideHorizontal).LineStyle = xlNone w_str = "t_" & ActiveSheet.name ActiveSheet.ListObjects.Add(xlSrcRange, Selection, , xlYes).name = w_str ActiveSheet.ListObjects(w_str).TableStyle = "TableStyleMedium13"
Range(w_str).Select With Selection .HorizontalAlignment = xlGeneral .VerticalAlignment = xlTop .Orientation = 0 .AddIndent = False .IndentLevel = 0 .ShrinkToFit = False .ReadingOrder = xlContext .MergeCells = False End With With Rows("1:1") .HorizontalAlignment = xlLeft .VerticalAlignment = xlTop .WrapText = False If ActiveSheet.ListObjects(w_str).ListColumns.Count > 20 Then .Orientation = xlVertical End If .AddIndent = False .IndentLevel = 0 .ShrinkToFit = False .ReadingOrder = xlContext .MergeCells = False End With
Range(w_str & "[#All]").Select Selection.ColumnWidth = 50 Selection.Columns.AutoFit Selection.Rows.AutoFit For Each w_range In ActiveSheet.ListObjects(w_str).HeaderRowRange Select Case w_range.Value Case "日付", "作成日", "更新日" w_range.EntireColumn.NumberFormatLocal = "yyyy-mm-dd;@" w_range.EntireColumn.AutoFit ActiveSheet.DisplayPageBreaks = False End Select Next w_range On Error GoTo l_wnd Range("t_時間集計[#Headers]").Select With Selection .HorizontalAlignment = xlLeft .VerticalAlignment = xlTop .WrapText = False .Orientation = xlVertical .AddIndent = False .IndentLevel = 0 .ShrinkToFit = False .ReadingOrder = xlContext .MergeCells = False End With Range("t_時間集計[#All]").Select Selection.Columns.AutoFit l_end: Rows("2:2").Select ActiveWindow.FreezePanes = True Range("A1").Select
End Sub
比較
比較
Sub シート_比較()
'シートを比較する
Dim s1 As Worksheet Dim s2 As Worksheet Dim s3 As Worksheet Dim r_end As Long Dim r1_end As Long Dim r2_end As Long Dim r3_end As Long
Dim c_end As Long Dim c1_end As Long Dim c2_end As Long Dim c3_end As Long Dim i As Long Dim j As Long
Set s1 = Sheets("旧") Set s2 = Sheets("新") Set s3 = Sheets("比較結果")
s3.Activate
With s1.UsedRange r1_end = .Row + .Rows.Count - 1 c1_end = .Column + .Columns.Count - 1 End With
With s2.UsedRange r2_end = .Row + .Rows.Count - 1 c2_end = .Column + .Columns.Count - 1 End With
With s3.UsedRange r3_end = .Row + .Rows.Count - 1 c3_end = .Column + .Columns.Count - 1 End With If r1_end > r2_end Then r_end = r1_end Else r_end = r2_end End If If c1_end > c2_end Then c_end = c1_end Else c_end = c2_end End If With s1 .Activate .Cells.Select With Selection.Interior .Pattern = xlNone .TintAndShade = 0 .PatternTintAndShade = 0 End With .Rows("1:1").Select With Selection.Interior .Pattern = xlSolid .PatternColorIndex = xlAutomatic .Color = 15773696 .TintAndShade = 0 .PatternTintAndShade = 0 End With .Columns("A:A").Select With Selection.Interior .PatternColorIndex = xlAutomatic .Color = 15773696 .TintAndShade = 0 .PatternTintAndShade = 0 End With End With With s2 .Activate .Cells.Select With Selection.Interior .Pattern = xlNone .TintAndShade = 0 .PatternTintAndShade = 0 End With .Rows("1:1").Select With Selection.Interior .Pattern = xlSolid .PatternColorIndex = xlAutomatic .Color = 15773696 .TintAndShade = 0 .PatternTintAndShade = 0 End With .Columns("A:A").Select With Selection.Interior .PatternColorIndex = xlAutomatic .Color = 15773696 .TintAndShade = 0 .PatternTintAndShade = 0 End With End With With s3 .Activate .Cells.Select With Selection.Interior .Pattern = xlNone .TintAndShade = 0 .PatternTintAndShade = 0 End With Selection.ClearContents .Rows("1:1").Select With Selection.Interior .Pattern = xlSolid .PatternColorIndex = xlAutomatic .Color = 15773696 .TintAndShade = 0 .PatternTintAndShade = 0 End With Selection.ClearContents .Columns("A:A").Select With Selection.Interior .PatternColorIndex = xlAutomatic .Color = 15773696 .TintAndShade = 0 .PatternTintAndShade = 0 End With Selection.ClearContents End With For i = 2 To r_end Application.StatusBar = i For j = 2 To c_end If s1.Cells(i, j).Value <> s2.Cells(i, j).Value Then s3.Cells(i, j).Value = "●" If Trim(s1.Cells(i, j).Value) = "" Or Trim(s2.Cells(i, j).Value) = "" Then s1.Cells(i, j).Interior.ColorIndex = 15 '薄灰 s2.Cells(i, j).Interior.ColorIndex = 15 '薄灰 s3.Cells(i, j).Interior.ColorIndex = 15 '薄灰 Else s1.Cells(i, j).Interior.ColorIndex = 3 '赤 s2.Cells(i, j).Interior.ColorIndex = 3 '赤 s3.Cells(i, j).Interior.ColorIndex = 3 '赤 End If s1.Cells(i, 1).Value = s3.Cells(i, 1).Value + 1 s1.Cells(1, j).Value = s3.Cells(1, j).Value + 1 s2.Cells(i, 1).Value = s3.Cells(i, 1).Value + 1 s2.Cells(1, j).Value = s3.Cells(1, j).Value + 1 s3.Cells(i, 1).Value = s3.Cells(i, 1).Value + 1 s3.Cells(1, j).Value = s3.Cells(1, j).Value + 1 End If Next j Next i
With s1 For i = 2 To r_end If .Cells(i, 1).Value > 0 Then .Cells(i, 1).Interior.ColorIndex = 3 End If Next i For j = 2 To c_end If .Cells(1, j).Value > 0 Then .Cells(1, j).Interior.ColorIndex = 3 End If Next j End With
With s2 For i = 2 To r_end If .Cells(i, 1).Value > 0 Then .Cells(i, 1).Interior.ColorIndex = 3 End If Next i For j = 2 To c_end If .Cells(1, j).Value > 0 Then .Cells(1, j).Interior.ColorIndex = 3 End If Next j End With With s3 For i = 2 To r_end If .Cells(i, 1).Value > 0 Then .Cells(i, 1).Interior.ColorIndex = 3 End If Next i For j = 2 To c_end If .Cells(1, j).Value > 0 Then .Cells(1, j).Interior.ColorIndex = 3 End If Next j End With MsgBox "終了" Application.StatusBar = False
End Sub
'シートを比較する
Dim s1 As Worksheet Dim s2 As Worksheet Dim s3 As Worksheet Dim r_end As Long Dim r1_end As Long Dim r2_end As Long Dim r3_end As Long
Dim c_end As Long Dim c1_end As Long Dim c2_end As Long Dim c3_end As Long Dim i As Long Dim j As Long
Set s1 = Sheets("旧") Set s2 = Sheets("新") Set s3 = Sheets("比較結果")
s3.Activate
With s1.UsedRange r1_end = .Row + .Rows.Count - 1 c1_end = .Column + .Columns.Count - 1 End With
With s2.UsedRange r2_end = .Row + .Rows.Count - 1 c2_end = .Column + .Columns.Count - 1 End With
With s3.UsedRange r3_end = .Row + .Rows.Count - 1 c3_end = .Column + .Columns.Count - 1 End With If r1_end > r2_end Then r_end = r1_end Else r_end = r2_end End If If c1_end > c2_end Then c_end = c1_end Else c_end = c2_end End If With s1 .Activate .Cells.Select With Selection.Interior .Pattern = xlNone .TintAndShade = 0 .PatternTintAndShade = 0 End With .Rows("1:1").Select With Selection.Interior .Pattern = xlSolid .PatternColorIndex = xlAutomatic .Color = 15773696 .TintAndShade = 0 .PatternTintAndShade = 0 End With .Columns("A:A").Select With Selection.Interior .PatternColorIndex = xlAutomatic .Color = 15773696 .TintAndShade = 0 .PatternTintAndShade = 0 End With End With With s2 .Activate .Cells.Select With Selection.Interior .Pattern = xlNone .TintAndShade = 0 .PatternTintAndShade = 0 End With .Rows("1:1").Select With Selection.Interior .Pattern = xlSolid .PatternColorIndex = xlAutomatic .Color = 15773696 .TintAndShade = 0 .PatternTintAndShade = 0 End With .Columns("A:A").Select With Selection.Interior .PatternColorIndex = xlAutomatic .Color = 15773696 .TintAndShade = 0 .PatternTintAndShade = 0 End With End With With s3 .Activate .Cells.Select With Selection.Interior .Pattern = xlNone .TintAndShade = 0 .PatternTintAndShade = 0 End With Selection.ClearContents .Rows("1:1").Select With Selection.Interior .Pattern = xlSolid .PatternColorIndex = xlAutomatic .Color = 15773696 .TintAndShade = 0 .PatternTintAndShade = 0 End With Selection.ClearContents .Columns("A:A").Select With Selection.Interior .PatternColorIndex = xlAutomatic .Color = 15773696 .TintAndShade = 0 .PatternTintAndShade = 0 End With Selection.ClearContents End With For i = 2 To r_end Application.StatusBar = i For j = 2 To c_end If s1.Cells(i, j).Value <> s2.Cells(i, j).Value Then s3.Cells(i, j).Value = "●" If Trim(s1.Cells(i, j).Value) = "" Or Trim(s2.Cells(i, j).Value) = "" Then s1.Cells(i, j).Interior.ColorIndex = 15 '薄灰 s2.Cells(i, j).Interior.ColorIndex = 15 '薄灰 s3.Cells(i, j).Interior.ColorIndex = 15 '薄灰 Else s1.Cells(i, j).Interior.ColorIndex = 3 '赤 s2.Cells(i, j).Interior.ColorIndex = 3 '赤 s3.Cells(i, j).Interior.ColorIndex = 3 '赤 End If s1.Cells(i, 1).Value = s3.Cells(i, 1).Value + 1 s1.Cells(1, j).Value = s3.Cells(1, j).Value + 1 s2.Cells(i, 1).Value = s3.Cells(i, 1).Value + 1 s2.Cells(1, j).Value = s3.Cells(1, j).Value + 1 s3.Cells(i, 1).Value = s3.Cells(i, 1).Value + 1 s3.Cells(1, j).Value = s3.Cells(1, j).Value + 1 End If Next j Next i
With s1 For i = 2 To r_end If .Cells(i, 1).Value > 0 Then .Cells(i, 1).Interior.ColorIndex = 3 End If Next i For j = 2 To c_end If .Cells(1, j).Value > 0 Then .Cells(1, j).Interior.ColorIndex = 3 End If Next j End With
With s2 For i = 2 To r_end If .Cells(i, 1).Value > 0 Then .Cells(i, 1).Interior.ColorIndex = 3 End If Next i For j = 2 To c_end If .Cells(1, j).Value > 0 Then .Cells(1, j).Interior.ColorIndex = 3 End If Next j End With With s3 For i = 2 To r_end If .Cells(i, 1).Value > 0 Then .Cells(i, 1).Interior.ColorIndex = 3 End If Next i For j = 2 To c_end If .Cells(1, j).Value > 0 Then .Cells(1, j).Interior.ColorIndex = 3 End If Next j End With MsgBox "終了" Application.StatusBar = False
End Sub
簡易比較
簡易比較
Sub シート_簡易比較()
'シートを簡易比較する
Dim s1 As Worksheet Dim s2 As Worksheet Dim r_end As Long Dim c_end As Long Dim r1_end As Long Dim c1_end As Long Dim r2_end As Long Dim c2_end As Long Dim i As Long Dim j As Long
Application.ScreenUpdating = False Application.DisplayAlerts = False On Error Resume Next Dim ws As Worksheet Dim condition As String condition = "【比較】" Application.DisplayAlerts = False For Each ws In ActiveWorkbook.Worksheets If InStr(ws.Name, condition) > 0 Then Debug.Print ws.Name ws.Delete End If Next ws Application.DisplayAlerts = True Err.Clear Worksheets(1).Select Worksheets(1).Copy After:=Sheets(Sheets.Count) ActiveSheet.Name = "【比較】" & Worksheets(1).Name Set s1 = ActiveSheet If Err.Number <> 0 Then ActiveSheet.Delete End If
Err.Clear Worksheets(2).Select Worksheets(2).Copy After:=Sheets(Sheets.Count) ActiveSheet.Name = "【比較】" & Worksheets(2).Name Set s2 = ActiveSheet If Err.Number <> 0 Then ActiveSheet.Delete End If s2.Move Before:=Sheets(1) s1.Move Before:=Sheets(1) On Error GoTo 0 Application.DisplayAlerts = True With s1.UsedRange r1_end = .row + .Rows.Count - 1 c1_end = .Column + .Columns.Count - 1 End With With s2.UsedRange r2_end = .row + .Rows.Count - 1 c2_end = .Column + .Columns.Count - 1 End With s1.Cells.EntireRow.Hidden = False s2.Cells.EntireColumn.Hidden = False s1.Cells.UnMerge s2.Cells.UnMerge If s1.AutoFilterMode Then If s1.FilterMode Then s1.ShowAllData End If End If If s2.AutoFilterMode Then If s2.FilterMode Then s2.ShowAllData End If End If If r1_end > r2_end Then r_end = r1_end Else r_end = r2_end End If If c1_end > c2_end Then c_end = c1_end Else c_end = c2_end End If s1.Range(s1.Cells(2, 1), s1.Cells(r_end, c_end)).Interior.ColorIndex = xlColorIndexNone s2.Range(s2.Cells(2, 1), s2.Cells(r_end, c_end)).Interior.ColorIndex = xlColorIndexNone
Dim FileName As String
' 出力するテキストファイルのパスを指定 FileName = ActiveWorkbook.Path & "\比較エラー.txt" ' ファイルを開く（なければ新規作成） Open FileName For Output As #1 Dim w_cnt As Integer w_cnt = 0 Dim w_flg As Boolean w_flg = False Dim w_cell1 As Range Dim w_cell2 As Range On Error Resume Next ' Debug.Print "================================================"
For i = 2 To r_end Application.StatusBar = i For j = 1 To c_end If CStr(s1.Cells(i, j).Value) <> CStr(s2.Cells(i, j).Value) Then If w_flg = False Then Set w_cell1 = s1.Cells(i, j) Set w_cell2 = s2.Cells(i, j) w_flg = True End If s1.Cells(i, j).Interior.ColorIndex = 3 s2.Cells(i, j).Interior.ColorIndex = 3 s1.Cells(i, j).Font.ThemeColor = xlThemeColorLight1 s2.Cells(i, j).Font.ThemeColor = xlThemeColorLight1 ' Debug.Print s1.Cells(i, j).Value & vbTab & vbTab & s2.Cells(i, j).Value' Print #1, s1.Cells(i, j).Value & vbTab & vbTab & s2.Cells(i, j).Value
Print #1, FixedWidthTab(s1.Cells(i, j).Value, 50) & s2.Cells(i, j).Value w_cnt = w_cnt + 1 End If Next j Next i On Error GoTo 0 ' ファイルを閉じる Close #1 Application.ScreenUpdating = True Worksheets(2).Activate w_cell2.Activate
Worksheets(1).Activate w_cell1.Activate
MsgBox "終了 " & w_cnt & "件" Application.StatusBar = False
End Sub
'シートを簡易比較する
Dim s1 As Worksheet Dim s2 As Worksheet Dim r_end As Long Dim c_end As Long Dim r1_end As Long Dim c1_end As Long Dim r2_end As Long Dim c2_end As Long Dim i As Long Dim j As Long
Application.ScreenUpdating = False Application.DisplayAlerts = False On Error Resume Next Dim ws As Worksheet Dim condition As String condition = "【比較】" Application.DisplayAlerts = False For Each ws In ActiveWorkbook.Worksheets If InStr(ws.Name, condition) > 0 Then Debug.Print ws.Name ws.Delete End If Next ws Application.DisplayAlerts = True Err.Clear Worksheets(1).Select Worksheets(1).Copy After:=Sheets(Sheets.Count) ActiveSheet.Name = "【比較】" & Worksheets(1).Name Set s1 = ActiveSheet If Err.Number <> 0 Then ActiveSheet.Delete End If
Err.Clear Worksheets(2).Select Worksheets(2).Copy After:=Sheets(Sheets.Count) ActiveSheet.Name = "【比較】" & Worksheets(2).Name Set s2 = ActiveSheet If Err.Number <> 0 Then ActiveSheet.Delete End If s2.Move Before:=Sheets(1) s1.Move Before:=Sheets(1) On Error GoTo 0 Application.DisplayAlerts = True With s1.UsedRange r1_end = .row + .Rows.Count - 1 c1_end = .Column + .Columns.Count - 1 End With With s2.UsedRange r2_end = .row + .Rows.Count - 1 c2_end = .Column + .Columns.Count - 1 End With s1.Cells.EntireRow.Hidden = False s2.Cells.EntireColumn.Hidden = False s1.Cells.UnMerge s2.Cells.UnMerge If s1.AutoFilterMode Then If s1.FilterMode Then s1.ShowAllData End If End If If s2.AutoFilterMode Then If s2.FilterMode Then s2.ShowAllData End If End If If r1_end > r2_end Then r_end = r1_end Else r_end = r2_end End If If c1_end > c2_end Then c_end = c1_end Else c_end = c2_end End If s1.Range(s1.Cells(2, 1), s1.Cells(r_end, c_end)).Interior.ColorIndex = xlColorIndexNone s2.Range(s2.Cells(2, 1), s2.Cells(r_end, c_end)).Interior.ColorIndex = xlColorIndexNone
Dim FileName As String
' 出力するテキストファイルのパスを指定 FileName = ActiveWorkbook.Path & "\比較エラー.txt" ' ファイルを開く（なければ新規作成） Open FileName For Output As #1 Dim w_cnt As Integer w_cnt = 0 Dim w_flg As Boolean w_flg = False Dim w_cell1 As Range Dim w_cell2 As Range On Error Resume Next ' Debug.Print "================================================"
For i = 2 To r_end Application.StatusBar = i For j = 1 To c_end If CStr(s1.Cells(i, j).Value) <> CStr(s2.Cells(i, j).Value) Then If w_flg = False Then Set w_cell1 = s1.Cells(i, j) Set w_cell2 = s2.Cells(i, j) w_flg = True End If s1.Cells(i, j).Interior.ColorIndex = 3 s2.Cells(i, j).Interior.ColorIndex = 3 s1.Cells(i, j).Font.ThemeColor = xlThemeColorLight1 s2.Cells(i, j).Font.ThemeColor = xlThemeColorLight1 ' Debug.Print s1.Cells(i, j).Value & vbTab & vbTab & s2.Cells(i, j).Value' Print #1, s1.Cells(i, j).Value & vbTab & vbTab & s2.Cells(i, j).Value
Print #1, FixedWidthTab(s1.Cells(i, j).Value, 50) & s2.Cells(i, j).Value w_cnt = w_cnt + 1 End If Next j Next i On Error GoTo 0 ' ファイルを閉じる Close #1 Application.ScreenUpdating = True Worksheets(2).Activate w_cell2.Activate
Worksheets(1).Activate w_cell1.Activate
MsgBox "終了 " & w_cnt & "件" Application.StatusBar = False
End Sub
使用範囲設定
使用範囲設定
Sub シート_使用範囲設定()
Dim s As Worksheet Dim r_start As Long Dim r_end As Long Dim c_start As Long Dim c_end As Long Dim i As Long Dim j As Long Set s = ActiveSheet With s.UsedRange r_start = .Row r_end = .Row + .Rows.Count - 1 c_start = .Column c_end = .Column + .Columns.Count - 1 End With End Sub
Dim s As Worksheet Dim r_start As Long Dim r_end As Long Dim c_start As Long Dim c_end As Long Dim i As Long Dim j As Long Set s = ActiveSheet With s.UsedRange r_start = .Row r_end = .Row + .Rows.Count - 1 c_start = .Column c_end = .Column + .Columns.Count - 1 End With End Sub
条件付き書式
条件付き書式
Option Explicit
Sub シート_条件付き書式_入力様式() '条件付き書式を設定する。 Dim s As Worksheet Dim c_end As Integer Dim c_end_gyou As Integer Dim c_end_address As String Cells.FormatConditions.Delete Set s = ActiveSheet With s.UsedRange c_end = .Column + .Columns.Count - 1 End With Range("C1").Select Range(Selection, Selection.End(xlToRight)).Select With Selection c_end_gyou = .Column + .Columns.Count - 1 End With '重複 Rows("3:3").Select Selection.FormatConditions.AddUniqueValues Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority Selection.FormatConditions(1).DupeUnique = xlDuplicate With Selection.FormatConditions(1).Font .Color = -16383844 .TintAndShade = 0 End With With Selection.FormatConditions(1).Interior .PatternColorIndex = xlAutomatic .Color = 13551615 .TintAndShade = 0 End With Selection.FormatConditions(1).StopIfTrue = False
'空白を赤色 Range(Range("C3"), Cells(3, c_end_gyou)).Select Selection.FormatConditions.Add Type:=xlExpression, Formula1:="=C14=""""" Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority With Selection.FormatConditions(1).Interior .PatternColorIndex = xlAutomatic .Color = 255 .TintAndShade = 0 End With Selection.FormatConditions(1).StopIfTrue = False
'空白を灰色 Range(Range("C2"), Cells(13, c_end_gyou)).Select Selection.FormatConditions.Add Type:=xlExpression, Formula1:="=AND(C$2="""",C$5="""",C$8="""",C$11="""")" Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority With Selection.FormatConditions(1).Interior .PatternColorIndex = xlAutomatic .ThemeColor = xlThemeColorDark1 .TintAndShade = -0.249946592608417 End With Selection.FormatConditions(1).StopIfTrue = False
'エラーを赤色 Cells.Select Selection.FormatConditions.Add Type:=xlExpression, Formula1:="=ISNA(A1)" Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority With Selection.FormatConditions(1).Interior .PatternColorIndex = xlAutomatic .Color = 255 .TintAndShade = 0 End With Selection.FormatConditions(1).StopIfTrue = False
'エラーを赤色 Cells(19, c_end).Select c_end_address = Selection.Address(RowAbsolute:=False) Range("B19:B23").Select Application.Union(Selection, Range("B34:B38")).Select Application.Union(Selection, Range("B49:B53")).Select Application.Union(Selection, Range("B64:B68")).Select Selection.FormatConditions.Add Type:=xlExpression, _ Formula1:="=COUNTIF($C19:" & c_end_address & ",""●"")+SUMPRODUCT(ISERROR($C19:" & c_end_address & ")*1)>0" Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority With Selection.FormatConditions(1).Interior .PatternColorIndex = xlAutomatic .Color = 255 .TintAndShade = 0 End With Selection.FormatConditions(1).StopIfTrue = False
End Sub
Sub シート_条件付き書式_入力様式() '条件付き書式を設定する。 Dim s As Worksheet Dim c_end As Integer Dim c_end_gyou As Integer Dim c_end_address As String Cells.FormatConditions.Delete Set s = ActiveSheet With s.UsedRange c_end = .Column + .Columns.Count - 1 End With Range("C1").Select Range(Selection, Selection.End(xlToRight)).Select With Selection c_end_gyou = .Column + .Columns.Count - 1 End With '重複 Rows("3:3").Select Selection.FormatConditions.AddUniqueValues Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority Selection.FormatConditions(1).DupeUnique = xlDuplicate With Selection.FormatConditions(1).Font .Color = -16383844 .TintAndShade = 0 End With With Selection.FormatConditions(1).Interior .PatternColorIndex = xlAutomatic .Color = 13551615 .TintAndShade = 0 End With Selection.FormatConditions(1).StopIfTrue = False
'空白を赤色 Range(Range("C3"), Cells(3, c_end_gyou)).Select Selection.FormatConditions.Add Type:=xlExpression, Formula1:="=C14=""""" Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority With Selection.FormatConditions(1).Interior .PatternColorIndex = xlAutomatic .Color = 255 .TintAndShade = 0 End With Selection.FormatConditions(1).StopIfTrue = False
'空白を灰色 Range(Range("C2"), Cells(13, c_end_gyou)).Select Selection.FormatConditions.Add Type:=xlExpression, Formula1:="=AND(C$2="""",C$5="""",C$8="""",C$11="""")" Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority With Selection.FormatConditions(1).Interior .PatternColorIndex = xlAutomatic .ThemeColor = xlThemeColorDark1 .TintAndShade = -0.249946592608417 End With Selection.FormatConditions(1).StopIfTrue = False
'エラーを赤色 Cells.Select Selection.FormatConditions.Add Type:=xlExpression, Formula1:="=ISNA(A1)" Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority With Selection.FormatConditions(1).Interior .PatternColorIndex = xlAutomatic .Color = 255 .TintAndShade = 0 End With Selection.FormatConditions(1).StopIfTrue = False
'エラーを赤色 Cells(19, c_end).Select c_end_address = Selection.Address(RowAbsolute:=False) Range("B19:B23").Select Application.Union(Selection, Range("B34:B38")).Select Application.Union(Selection, Range("B49:B53")).Select Application.Union(Selection, Range("B64:B68")).Select Selection.FormatConditions.Add Type:=xlExpression, _ Formula1:="=COUNTIF($C19:" & c_end_address & ",""●"")+SUMPRODUCT(ISERROR($C19:" & c_end_address & ")*1)>0" Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority With Selection.FormatConditions(1).Interior .PatternColorIndex = xlAutomatic .Color = 255 .TintAndShade = 0 End With Selection.FormatConditions(1).StopIfTrue = False
End Sub
条件付き書式_QAシート
条件付き書式_QAシート
Sub シート_条件付き書式_QAシート() Cells.FormatConditions.Delete '完了を灰色 Range("I3:M1048576").Select Selection.FormatConditions.Add Type:=xlExpression, Formula1:= "=$K3=""完了""" Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority With Selection.FormatConditions(1).Interior .PatternColorIndex = xlAutomatic .ThemeColor = xlThemeColorDark1 .TintAndShade = -0.14996795556505 End With Selection.FormatConditions(1).StopIfTrue = False
End Sub
End Sub
条件付き書式_入力様式
条件付き書式_入力様式
Sub シート_条件付き書式_入力様式() '条件付き書式を設定する。 Dim c_end As Integer Cells.FormatConditions.Delete '重複 Rows("3:3").Select Selection.FormatConditions.AddUniqueValues Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority Selection.FormatConditions(1).DupeUnique = xlDuplicate With Selection.FormatConditions(1).Font .Color = -16383844 .TintAndShade = 0 End With With Selection.FormatConditions(1).Interior .PatternColorIndex = xlAutomatic .Color = 13551615 .TintAndShade = 0 End With Selection.FormatConditions(1).StopIfTrue = False
'空白を赤色 Range("B14").Select Range(Selection, Selection.End(xlToRight)).Select With Selection c_end = .Column + .Columns.Count - 1 End With Selection.FormatConditions.Add Type:=xlExpression, Formula1:="=B14=""""" Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority With Selection.FormatConditions(1).Interior .PatternColorIndex = xlAutomatic .Color = 255 .TintAndShade = 0 End With Selection.FormatConditions(1).StopIfTrue = False
'空白を灰色 Range(Range("B2"), Cells(13, c_end)).Select Selection.FormatConditions.Add Type:=xlExpression, Formula1:="=AND(B$2="""",B$5="""",B$8="""",B$11="""")" Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority With Selection.FormatConditions(1).Interior .PatternColorIndex = xlAutomatic .ThemeColor = xlThemeColorDark1 .TintAndShade = -0.249946592608417 End With Selection.FormatConditions(1).StopIfTrue = False
'エラーを赤色 Range("B19:B23").Select Application.Union(Selection, Range("B34:B38")).Select Application.Union(Selection, Range("B49:B53")).Select Application.Union(Selection, Range("B64:B68")).Select Selection.FormatConditions.Add Type:=xlExpression, Formula1:="=COUNTIF($C19:$XFD19,""●"")+SUMPRODUCT(ISERROR($C19:$XFD19)*1)>0" Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority With Selection.FormatConditions(1).Interior .PatternColorIndex = xlAutomatic .Color = 255 .TintAndShade = 0 End With Selection.FormatConditions(1).StopIfTrue = False
'エラーを赤色 Cells.Select Selection.FormatConditions.Add Type:=xlExpression, Formula1:="=ISNA(A1)" Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority With Selection.FormatConditions(1).Interior .PatternColorIndex = xlAutomatic .Color = 255 .TintAndShade = 0 End With Selection.FormatConditions(1).StopIfTrue = False
End Sub
'空白を赤色 Range("B14").Select Range(Selection, Selection.End(xlToRight)).Select With Selection c_end = .Column + .Columns.Count - 1 End With Selection.FormatConditions.Add Type:=xlExpression, Formula1:="=B14=""""" Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority With Selection.FormatConditions(1).Interior .PatternColorIndex = xlAutomatic .Color = 255 .TintAndShade = 0 End With Selection.FormatConditions(1).StopIfTrue = False
'空白を灰色 Range(Range("B2"), Cells(13, c_end)).Select Selection.FormatConditions.Add Type:=xlExpression, Formula1:="=AND(B$2="""",B$5="""",B$8="""",B$11="""")" Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority With Selection.FormatConditions(1).Interior .PatternColorIndex = xlAutomatic .ThemeColor = xlThemeColorDark1 .TintAndShade = -0.249946592608417 End With Selection.FormatConditions(1).StopIfTrue = False
'エラーを赤色 Range("B19:B23").Select Application.Union(Selection, Range("B34:B38")).Select Application.Union(Selection, Range("B49:B53")).Select Application.Union(Selection, Range("B64:B68")).Select Selection.FormatConditions.Add Type:=xlExpression, Formula1:="=COUNTIF($C19:$XFD19,""●"")+SUMPRODUCT(ISERROR($C19:$XFD19)*1)>0" Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority With Selection.FormatConditions(1).Interior .PatternColorIndex = xlAutomatic .Color = 255 .TintAndShade = 0 End With Selection.FormatConditions(1).StopIfTrue = False
'エラーを赤色 Cells.Select Selection.FormatConditions.Add Type:=xlExpression, Formula1:="=ISNA(A1)" Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority With Selection.FormatConditions(1).Interior .PatternColorIndex = xlAutomatic .Color = 255 .TintAndShade = 0 End With Selection.FormatConditions(1).StopIfTrue = False
End Sub
条件付き書式_動作確認
条件付き書式_動作確認
Sub シート_条件付き書式_動作確認() 'シートの条件付き書式を設定しなおす。 Cells.FormatConditions.Delete Range("E:E,J:J,O:O").Select Selection.FormatConditions.Add Type:=xlCellValue, Operator:=xlEqual, Formula1:="=""NG""" Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority With Selection.FormatConditions(1).Interior .PatternColorIndex = xlAutomatic .Color = 13551615 .TintAndShade = 0 End With Selection.FormatConditions(1).StopIfTrue = True Selection.FormatConditions.Add Type:=xlCellValue, Operator:=xlEqual, Formula1:="=""NG→既存バグ""" Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority With Selection.FormatConditions(1).Interior .PatternColorIndex = xlAutomatic .Color = 10284031 .TintAndShade = 0 End With Selection.FormatConditions(1).StopIfTrue = True Selection.FormatConditions.Add Type:=xlCellValue, Operator:=xlEqual, Formula1:="=""NG→OK""" Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority With Selection.FormatConditions(1).Interior .PatternColorIndex = xlAutomatic .Color = 10284031 .TintAndShade = 0 End With Selection.FormatConditions(1).StopIfTrue = True Selection.FormatConditions.Add Type:=xlCellValue, Operator:=xlEqual, Formula1:="=""環境設定要""" Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority With Selection.FormatConditions(1).Interior .PatternColorIndex = xlAutomatic .Color = 10284031 .TintAndShade = 0 End With Selection.FormatConditions(1).StopIfTrue = True Selection.FormatConditions.Add Type:=xlCellValue, Operator:=xlEqual, Formula1:="=""OK""" Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority With Selection.FormatConditions(1).Interior .PatternColorIndex = xlAutomatic .ThemeColor = xlThemeColorAccent1 .TintAndShade = 0.799981688894314 End With Selection.FormatConditions(1).StopIfTrue = True Selection.FormatConditions.Add Type:=xlCellValue, Operator:=xlEqual, Formula1:="=""OK（データ無）""" Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority With Selection.FormatConditions(1).Interior .PatternColorIndex = xlAutomatic .ThemeColor = xlThemeColorAccent1 .TintAndShade = 0.799981688894314 End With Selection.FormatConditions(1).StopIfTrue = True End Sub
ズーム
ズーム
Sub シート_ズーム() 'シートのzoomを変更する。 If ActiveWindow.Zoom = 100 Then ActiveWindow.Zoom = 150 ElseIf ActiveWindow.Zoom = 150 Then ActiveWindow.Zoom = 200 Else ActiveWindow.Zoom = 100 End If End Sub
Page updated
Google Sites
Report abuse