エクセル顧客管理
処理速度の向上はどこまでやれば良い（GW特別号No3）

Sub 顧客登録シート作成(Optional ByVal blnEvent As Boolean = False)
　　Dim r1 As Long, c1 As Long
　　Dim r2 As Long, c2 As Long
　　Dim intW As Integer
　　Dim rng1 As Range, rng2 As Range
　　If blnEvent = False Then Call マクロ開始処理

　　r1 = 開始セル取得("顧客一覧").Row
　　c1 = 開始セル取得("顧客一覧").Column
　　r2 = 開始セル取得("顧客登録").Row
　　c2 = 開始セル取得("顧客登録").Column

　　With シート取得("顧客登録")
　　　　.Unprotect
　　　　.UsedRange.Clear
　　　　
　　　　Do Until IsEmpty(シート取得("顧客一覧").Cells(r1, c1))
　　　　　　シート取得("顧客一覧").Cells(r1, c1).Copy .Cells(r2, c2)
　　　　　　シート取得("顧客一覧").Cells(r1 + 1, c1).Copy .Cells(r2, c2 + 1)
　　　　　　intW = Round(シート取得("顧客一覧").Columns(c1).Width / .Columns(c2 + 1).Width, 0)
　　　　　　
　　　　　　If rng1 Is Nothing Then
　　　　　　　　Set rng1 = .Range(.Cells(r2, c2), .Cells(r2, c2 + 1 + intW))
　　　　　　　　Set rng2 = .Range(.Cells(r2, c2 + 1), .Cells(r2, c2 + 1 + intW))
　　　　　　Else
　　　　　　　　Set rng1 = Union(rng1, .Range(.Cells(r2, c2), .Cells(r2, c2 + 1 + intW)))
　　　　　　　　Set rng2 = Union(rng2, .Range(.Cells(r2, c2 + 1), .Cells(r2, c2 + 1 + intW)))
　　　　　　End If
　　　　　　
　　　　　　c1 = c1 + 1
　　　　　　r2 = r2 + 2
　　　　Loop
　　　　
　　　　rng2.ClearContents
　　　　rng2.MergeCells = True
　　　　rng2.Locked = False
　　　　rng1.Borders.LineStyle = xlContinuous
　　　　
　　　　.EnableSelection = xlUnlockedCells
　　　　.Protect DrawingObjects:=False, Contents:=True, Scenarios:=False
　　　　.Select
　　　　開始セル取得("顧客登録").Offset(0, 1).Select
　　End With
　　
　　With ActiveWindow
　　　　.DisplayGridlines = False
　　　　.DisplayHeadings = False
　　End With
　　
　　If blnEvent = False Then Call マクロ終了処理
End Sub

Sub 顧客登録シート作成3(Optional ByVal blnEvent As Boolean = False)
　　Dim r1 As Long, c1 As Long
　　Dim r2 As Long, c2 As Long
　　Dim intW As Integer
　　
　　Dim sht一覧 As Worksheet, sht登録 As Worksheet
　　Dim rng1 As Range, rng2 As Range
　　Dim var As Variant
　　Dim i1 As Long, i2 As Long
　　
　　If blnEvent = False Then Call マクロ開始処理

　　r1 = 開始セル取得("顧客一覧").Row
　　c1 = 開始セル取得("顧客一覧").Column
　　r2 = 開始セル取得("顧客登録").Row
　　c2 = 開始セル取得("顧客登録").Column

　　Set sht一覧 = シート取得("顧客一覧")
　　Set sht登録 = シート取得("顧客登録")
　　var = sht一覧.Range(sht一覧.Cells(r1, 1), sht一覧.Cells(r1, sht一覧.Cells.SpecialCells(xlLastCell).Column))
　　i2 = r2
　　With sht登録
　　　　.Unprotect
　　　　.UsedRange.Clear

　　　　For i1 = c1 To UBound(var, 2)
　　　　　　If var(1, i1) = "" Then
　　　　　　　　Exit For
　　　　　　End If
　　　　　　sht一覧.Cells(r1, i1).Copy .Cells(i2, c2)
　　　　　　sht一覧.Cells(r1 + 1, i1).Copy .Cells(i2, c2 + 1)
　　　　　　intW = Round(sht一覧.Columns(c1).Width / .Columns(c2 + 1).Width, 0)
　　　　　　
　　　　　　If rng1 Is Nothing Then
　　　　　　　　Set rng1 = .Range(.Cells(i2, c2), .Cells(r2, c2 + 1 + intW))
　　　　　　　　Set rng2 = .Range(.Cells(i2, c2 + 1), .Cells(i2, c2 + 1 + intW))
　　　　　　Else
　　　　　　　　Set rng1 = Union(rng1, .Range(.Cells(i2, c2), .Cells(i2, c2 + 1 + intW)))
　　　　　　　　Set rng2 = Union(rng2, .Range(.Cells(i2, c2 + 1), .Cells(i2, c2 + 1 + intW)))
　　　　　　End If
　　　　　　i2 = i2 + 2
　　　　Next
　　　　
　　　　rng2.ClearContents
　　　　rng2.MergeCells = True
　　　　rng2.Locked = False
　　　　rng1.Borders.LineStyle = xlContinuous
　　　　
　　　　.EnableSelection = xlUnlockedCells
　　　　.Protect DrawingObjects:=False, Contents:=True, Scenarios:=False
　　　　.Select
　　　　.Cells(r2, c2 + 1).Select
　　End With
　　
　　With ActiveWindow
　　　　.DisplayGridlines = False
　　　　.DisplayHeadings = False
　　End With
　　
　　If blnEvent = False Then Call マクロ終了処理
End Sub