Notes

'セル表示形式変更

'HA 表示水平位置
'VA 表示垂直位置
'OT 文字回転
'strUserFormat ユーザー定義書式
'lFontSize フォントサイズ
'bBold 太字
'bItalic 斜体

Public Sub Change_CellDisplayFormat(ByVal lRowST As Long, ByVal lColST As Long, _
ByVal lRowED As Long, ByVal lColED As Long, _
Optional ByVal HA As XlHAlign = xlHAlignCenter, _
Optional ByVal VA As XlVAlign = xlVAlignCenter, _
Optional ByVal OT As XlOrientation = xlHorizontal, _
Optional ByVal strUserFormat As String = "", _
Optional ByVal lFontSize As Long = 0, _
Optional ByVal bBold As Boolean = False, _
Optional ByVal bItalic As Boolean = False)
Dim rng As Range
With m_wsSheet
Set rng = .Range(.Cells(lRowST, lColST), .Cells(lRowED, lColED))
End With
With rng
.HorizontalAlignment = HA
.VerticalAlignment = VA
.Orientation = OT
If strUserFormat <> "" Then .NumberFormatLocal = strUserFormat
If lFontSize > 0 Then .Font.Size = lFontSize
.Font.Bold = bBold
.Font.Italic = bItalic
End With

End Sub

'**********************************************************************************************

'セル表示形式変更(行か列全体に反映)

'bDirection_Row true:行方向 false:列方向
'HA 表示水平位置
'VA 表示垂直位置
'OT 文字回転
'strUserFormat ユーザー定義書式
'lFontSize フォントサイズ
'bBold 太字
'bItalic 斜体

Public Sub Change_LineDisplayFormat(ByVal lST As Long, ByVal lED As Long, _
Optional ByVal bDirection_Row As Boolean = True, _
Optional ByVal HA As XlHAlign = xlHAlignCenter, _
Optional ByVal VA As XlVAlign = xlVAlignCenter, _
Optional ByVal OT As XlOrientation = xlHorizontal, _
Optional ByVal strUserFormat As String = "", _
Optional ByVal lFontSize As Long = 0, _
Optional ByVal bBold As Boolean = False, _
Optional ByVal bItalic As Boolean = False)
Dim rng As Range

With m_wsSheet

If bDirection_Row = True Then
Set rng = .Range(.Cells(lST, 1), .Cells(lED, 1)).EntireRow
Else
Set rng = .Range(.Cells(1, lST), .Cells(1, lED)).EntireColumn
End If

End With

With rng
.HorizontalAlignment = HA
.VerticalAlignment = VA
.Orientation = OT
If strUserFormat <> "" Then .NumberFormatLocal = strUserFormat
If lFontSize > 0 Then .Font.Size = lFontSize
.Font.Bold = bBold
.Font.Italic = bItalic
End With

End Sub

'**********************************************************************************************

'2次元配列に要素追加

Public Sub Add_Array_for_2_Dimension(Optional ByVal lCount As Long = 1)

ReDim Preserve m_varAry(LBound(m_varAry, 1) To UBound(m_varAry, 1), LBound(m_varAry, 2) To UBound(m_varAry, 2) + lCount)

End Sub

'**********************************************************************************************

'シートの範囲をコピー&ペースト

Public Sub CopyAndPaste_SheetRange(ByRef rngPaste As Range, _
Optional ByVal PT As XlPasteType = xlPasteAll, _
Optional ByVal lRowST As Long = -1, Optional ByVal lColST As Long = -1, _
Optional ByVal lRowED As Long = -1, Optional ByVal lColED As Long = -1)

With m_wsSheet
If lRowST > 0 And lColST > 0 And lRowED > 0 And lColED > 0 Then
.Range(.Cells(lRowST, lColST), .Cells(lRowED, lColED)).Copy
Else
.Range(.Cells(1, 1), .Cells(m_lRow_Last, m_lCol_Last)).Copy
End If
End With
Call rngPaste.PasteSpecial(PT)
Application.CutCopyMode = False

End Sub

'**********************************************************************************************

'対象シートに指定範囲の行列サイズをコピー

Public Sub CopyAndPaste_CellSize(ByRef wsPaste As Worksheet, ByVal lRowST As Long, ByVal lColST As Long, _
ByVal lRowED As Long, ByVal lColED As Long)

Dim i As Long
For i = lRowST To lRowED Step 1
wsPaste.Rows(i).RowHeight = m_wsSheet.Rows(i).RowHeight
Next i
For i = lColST To lColED Step 1
wsPaste.Columns(i).ColumnWidth = m_wsSheet.Columns(i).ColumnWidth
Next i

End Sub

'**********************************************************************************************

'行列入れ替え(空対応版)
Public Function MyTranspose(ByRef varAry As Variant) As Variant

Dim i As Long
Dim j As Long
Dim varAryTemp() As Variant
ReDim varAryTemp(LBound(varAry, 2) To UBound(varAry, 2), LBound(varAry, 1) To UBound(varAry, 1))

For i = LBound(varAry, 1) To UBound(varAry, 1) Step 1
For j = LBound(varAry, 2) To UBound(varAry, 2) Step 1
If IsEmpty(varAry(i, j)) Then
varAryTemp(j, i) = ""
Else
varAryTemp(j, i) = varAry(i, j)
End If
Next j
Next i
MyTranspose = varAryTemp

End Function

'**********************************************************************************************

'フィルタ解除

Public Sub Release_Filter()

If m_wsSheet.AutoFilterMode = False Then Exit Sub
If m_wsSheet.FilterMode = False Then Exit Sub
Call m_wsSheet.ShowAllData

End Sub

'**********************************************************************************************

'オートフィルタセット

Public Sub Set_AutoFilter(ByVal lTargetRow As Long)

With m_wsSheet
Call .Range(.Cells(lTargetRow, m_lCol_Table_ST), .Cells(m_lRow_Last, m_lCol_Last)).AutoFilter
End With

End Sub

'**********************************************************************************************

'配列の要素数取得

Public Function Get_ArrayCount(ByRef varAry As Variant, Optional ByVal lDimension As Long = 1) As Long

Get_ArrayCount = -1
Get_ArrayCount = UBound(varAry, lDimension) - LBound(varAry, lDimension) + 1

End Function

'**********************************************************************************************

'行列逆転したバリアント2次元配列を逆転してメンバシートに貼り付け

Public Sub Paste_Data_to_Sheet(Optional ByRef varAry As Variant = Empty, _
Optional ByVal lRowST As Long = 1, Optional ByVal lColST As Long = 1)

Dim lRowCount As Long
Dim lColCount As Long
Dim rng As Range

If Not varAry = Empty Then
lRowCount = Get_ArrayCount(varAry, 2)
lColCount = Get_ArrayCount(varAry, 1)
Else
varAry = m_varAry
lRowCount = Get_ArrayCount(m_varAry, 2)
lColCount = Get_ArrayCount(m_varAry, 1)
End If
With m_wsSheet
Set rng = .Range(.Cells(lRowST, lColST), .Cells(lRowST + lRowCount - 1, lColST + lColCount - 1))
rng = MyTranspose(varAry)
End With
Call Me.Refresh_Proc
Call rng.Rows.AutoFit
Call rng.Columns.AutoFit
Set rng = Nothing

End Sub

'**********************************************************************************************

'バリアント2次元配列をメンバシートに貼り付け

Public Sub Paste_Data_to_Sheet2(ByRef varAry As Variant, Optional ByVal lRowST As Long = 1, _
Optional ByVal lColST As Long = 1)

Dim lRowCount As Long
Dim lColCount As Long
lRowCount = Get_ArrayCount(varAry, 1)
lColCount = Get_ArrayCount(varAry, 2)
With m_wsSheet
.Range(.Cells(lRowST, lColST), _
.Cells(lRowST + lRowCount - 1, lColST + lColCount - 1)) = varAry
End With
Call Me.Refresh_Proc

End Sub

'**********************************************************************************************

'結合された最初のセルの個数(列個数)取得

Public Function Get_MergeCell_Count(ByVal lRow As Long) As Long

Get_MergeCell_Count = -1
Dim i As Long
With m_wsSheet
For i = 1 To m_lCol_Last Step 1
If .Cells(lRow, i).MergeCells = False Then GoTo CONTINUE
Get_MergeCell_Count = .Cells(lRow, i).MergeArea.Columns.Count
Exit Function
CONTINUE:
Next i
End With

End Function

'**********************************************************************************************

'最終行取得(結合セル対応)

Public Function Get_LastRow_supperts_MergeCell() As Long

Dim i As Long
Get_LastRow_supperts_MergeCell = -1
i = m_lRow_BaseLine
Do While True
If CStr(m_wsSheet.Cells(i, m_lCol_BaseLine).Value) <> "" Then GoTo CONTINUE
If m_wsSheet.Cells(i, m_lCol_BaseLine).MergeCells = True Then GoTo CONTINUE
Get_LastRow_supperts_MergeCell = i - 1
Exit Function
CONTINUE:
i = i + 1
Loop

End Function

'**********************************************************************************************

'最終列取得(結合セル対応)

Public Function Get_LastCol_supperts_MergeCell() As Long

Dim i As Long
Get_LastCol_supperts_MergeCell = -1
i = m_lCol_BaseLine
Do While True
If CStr(m_wsSheet.Cells(m_lRow_BaseLine, i).Value) <> "" Then GoTo CONTINUE
If m_wsSheet.Cells(m_lRow_BaseLine, i).MergeCells = True Then GoTo CONTINUE
Get_LastCol_supperts_MergeCell = i - 1
Exit Function
CONTINUE:
i = i + 1
Loop

End Function

'**********************************************************************************************

'シートクリア

'bDataPart true: データ部 false: 表全体
'lClearType 1:全て、2:コメント、3:値と数式、4:書式(色や罫線、条件付き書式など)
' 5:コメント、値と数式、背景色

Public Sub Clear_Sheet(Optional ByVal lClearType As Long = 1, Optional ByVal bDataPart As Boolean = False)

Dim rng As Range
With m_wsSheet
If bDataPart = True Then
Set rng = .Range(.Cells(m_lRow_DataST, m_lCol_DataST), .Cells(m_lRow_Last, m_lCol_Last))
Else
Set rng = .Range(.Cells(m_lRow_Table_ST, m_lCol_Table_ST), .Cells(m_lRow_Last, m_lCol_Last))
End If
End With

Select Case lClearType
Case 1
Call rng.Clear
Case 2
Call rng.ClearComments
Case 3
Call rng.ClearContents
Case 4
Call rng.ClearFormats
Case 5
Call rng.ClearComments
Call rng.ClearContents
rng.Interior.ColorIndex = xlNone
End Select

Set rng = Nothing

End Sub

'**********************************************************************************************

'範囲クリア

'lClearType 1:全て、2:コメント、3:値と数式、4:書式(色や罫線、条件付き書式など)
' 5:コメント、値と数式、背景色

Public Sub Clear_Range(ByVal lRowST As Long, ByVal lColST As Long, ByVal lRowED As Long, _
ByVal lColED As Long, Optional ByVal lClearType As Long = 1)

Dim rng As Range
With m_wsSheet
Set rng = .Range(.Cells(lRowST, lColST), .Cells(lRowED, lColED))
End With

Select Case lClearType
Case 1
Call rng.Clear
Case 2
Call rng.ClearComments
Case 3
Call rng.ClearContents
Case 4
Call rng.ClearFormats
Case 5
Call rng.ClearComments
Call rng.ClearContents
rng.Interior.ColorIndex = xlNone
End Select

Set rng = Nothing

End Sub

'**********************************************************************************************

'行列挿入

'IFO xlFormatFromLeftOrAbove:左か上から xlformatfromrightorbelow:右か下から書式コピー
'bInsert_Direction_Row true:行方向 false:列方向

Public Sub Insert_Line_on_Sheet(Optional ByVal lInsertCount As Long = 1, _
Optional ByVal lInsertPos As Long = 0, _
Optional ByVal bCopyLine As Boolean = False, _
Optional ByVal IFO As XlInsertFormatOrigin = xlFormatFromLeftOrAbove, _
Optional ByVal bInsert_Direction_Row As Boolean = True)

Dim lPos As Long
With m_wsSheet

If bInsert_Direction_Row = True Then
If lInsertPos > 0 Then
lPos = lInsertPos
Else
lPos = m_lRow_Last + 1
End If

If bCopyLine = False Then
Call .Range(.Cells(lPos, 1), .Cells(lPos + lInsertCount - 1, 1)).EntireRow.Insert(, IFO)
Else
Call .Range(.Cells(lPos, 1), .Cells(lPos + lInsertCount - 1, 1)).EntireRow.Copy
Call .Range(.Cells(lPos, 1), .Cells(lPos + lInsertCount - 1, 1)).EntireRow.PasteSpecial
End If
Else
If lInsertPos > 0 Then
lPos = lInsertPos
Else
lPos = m_lCol_Last + 1
End If

If bCopyLine = False Then
Call .Range(.Cells(1, lPos), .Cells(1, lPos + lInsertCount - 1)).EntireColumn.Insert(, IFO)
Else
Call .Range(.Cells(1, lPos), .Cells(1, lPos + lInsertCount - 1)).EntireColumn.Copy
Call .Range(.Cells(1, lPos), .Cells(1, lPos + lInsertCount - 1)).EntireColumn.PasteSpecial
End If
End If

End With

End Sub

'**********************************************************************************************

'行列削除

'bDirection_Row true:行方向 false:列方向

Public Sub Delete_Line_on_Sheet(Optional ByVal lDeleteCount As Long = 1, _
Optional ByVal lDeletePos As Long = 0, _
Optional ByVal bDirection_Row As Boolean = True)

Dim lPos As Long
With m_wsSheet

If bDirection_Row = True Then
If lDeletePos > 0 Then
lPos = lDeletePos
Else
lPos = m_lRow_Last - lDeleteCount + 1
End If
Call .Range(.Cells(lPos, 1), .Cells(lPos + lDeleteCount - 1, 1)).EntireRow.Delete
Else
If lDeletePos > 0 Then
lPos = lDeletePos
Else
lPos = m_lCol_Last - lDeleteCount + 1
End If
Call .Range(.Cells(1, lPos), .Cells(1, lPos + lDeleteCount - 1)).EntireColumn.Delete
End If

End With

End Sub

'**********************************************************************************************

'行列コピー＆ペースト

'bDirection_Row true:行方向 false:列方向

Public Sub Copy_Line_and_Paste_on_Sheet(ByVal lCopyPos As Long, ByVal lPastePos As Long, _
Optional ByVal lCopyCount As Long = 1, _
Optional ByVal PT As XlPasteType = xlPasteAll, _
Optional ByVal bDirection_Row As Boolean = True, _
Optional ByRef ws_in As Worksheet = Nothing, _
Optional ByRef ws_out As Worksheet = Nothing)

If ws_in Is Nothing Then Set ws_in = m_wsSheet
If ws_out Is Nothing Then Set ws_out = m_wsSheet
With ws_in

If bDirection_Row = True Then
Call .Range(.Cells(lCopyPos, 1), .Cells(lCopyPos + lCopyCount - 1, 1)).EntireRow.Copy
Else
Call .Range(.Cells(1, lCopyPos), .Cells(1, lCopyPos + lCopyCount - 1)).EntireColumn.Copy
End If

End With
With ws_out

If bDirection_Row = True Then
Call .Range(.Cells(lPastePos, 1), .Cells(lPastePos, 1)).EntireRow.PasteSpecial(PT)
Else
Call .Range(.Cells(1, lCopyPos), .Cells(1, lPastePos)).EntireColumn.PasteSpecial(PT)
End If

End With

Application.CutCopyMode = False

End Sub

'**********************************************************************************************

'選択セルとスクロール位置をA1に

Public Sub Clear_SelectPos()

' Call Application.Goto(m_wsSheet.Cells(1, 1), True)
Call ActiveSheet.Cells(1, 1).Select
With ActiveWindow
.ScrollRow = 1
.ScrollColumn = 1
End With

End Sub

'**********************************************************************************************

'検索文字列を行か列から全て見つける(シート内から)

Public Function Search_CellNumbers(ByVal strTarget As String, ByVal lLineNo As Long, _
Optional ByVal bDirection_Row As Boolean = True, _
Optional ByVal lLastLimit As Long = 0) As Long()

Dim lAry() As Long
Dim rng As Range
Dim lLast As Long

If lLastLimit > 0 Then
lLast = lLastLimit
Else
lLast = m_wsSheet.Rows.Count
End If

With m_wsSheet

'行方向
If bDirection_Row = True Then
Set rng = .Cells(1, lLineNo).EntireColumn.Find(strTarget, , xlValues, xlWhole, _
xlByRows, xlNext, True, True)
If rng Is Nothing Then Exit Function
Call Add_Array_for_1_Dimension(lAry)
lAry(UBound(lAry)) = rng.Row

Do While True
Set rng = .Cells(1, lLineNo).EntireColumn.FindNext(rng)
'1週したら終了
If rng.Row = lAry(LBound(lAry)) Or rng.Row > lLast Then
Search_CellNumbers = lAry
Exit Function
End If
Call Add_Array_for_1_Dimension(lAry)
lAry(UBound(lAry)) = rng.Row
Loop
'列方向
Else
Set rng = .Cells(lLineNo, 1).EntireRow.Find(strTarget, , xlValues, xlWhole, _
xlByColumns, xlNext, True, True)
If rng Is Nothing Then Exit Function
Call Add_Array_for_1_Dimension(lAry)
lAry(UBound(lAry)) = rng.Column

Do While True
Set rng = .Cells(lLineNo, 1).EntireRow.FindNext(rng)
'1週したら終了
If rng.Row = lAry(LBound(lAry)) Or rng.Column > lLast Then
Search_CellNumbers = lAry
Exit Function
End If
Call Add_Array_for_1_Dimension(lAry)
lAry(UBound(lAry)) = rng.Column
Loop
End If

End With

End Function

'**********************************************************************************************

'範囲内のシェイプを削除

Public Sub Delete_Shape_in_PartRange(Optional ByVal lX_ST As Long = -1, Optional ByVal lX_ED As Long = -1, _
Optional ByVal lY_ST As Long = -1, Optional ByVal lY_ED As Long = -1, _
Optional ByVal ST As MsoShapeType = -1, _
Optional ByVal AST As MsoAutoShapeType = -1)
Dim shp As Shape

For Each shp In m_wsSheet.Shapes
If lX_ST >= 0 And lX_ED > 0 Then
If shp.Left < lX_ST Or shp.Left > lX_ED Then GoTo CONTINUE
End If
If lY_ST >= 0 And lY_ED > 0 Then
If shp.Top < lY_ST Or shp.Top > lY_ED Then GoTo CONTINUE
End If
If ST > 0 And shp.Type <> ST Then GoTo CONTINUE
If AST > 0 And shp.AutoShapeType <> AST Then GoTo CONTINUE
Call shp.Delete
CONTINUE:
Next shp

End Sub

'**********************************************************************************************

'シェイプのリサイズ

Public Sub Resize_Shape(Optional ByVal lTop As Long = -1, Optional ByVal lHeight As Long = -1, _
Optional ByVal lLeft As Long = -1, Optional ByVal lWidth As Long = -1, _
Optional ByVal bDiff As Boolean = True, Optional ByVal ST As MsoShapeType = -1, _
Optional ByVal AST As MsoAutoShapeType = -1)
Dim shp As Shape

For Each shp In m_wsSheet.Shapes
If ST > 0 And shp.Type <> ST Then GoTo CONTINUE
If AST > 0 And shp.AutoShapeType <> AST Then GoTo CONTINUE
'差分なら
If bDiff = True Then
If lTop > 0 Then shp.Top = shp.Top + lTop
If lHeight > 0 Then shp.Height = shp.Height + lHeight
If lLeft > 0 Then shp.Left = shp.Left + lLeft
If lWidth > 0 Then shp.Width = shp.Width + lWidth
'絶対値なら
Else
If lTop > 0 Then shp.Top = lTop
If lHeight > 0 Then shp.Height = lHeight
If lLeft > 0 Then shp.Left = lLeft
If lWidth > 0 Then shp.Width = lWidth
End If
CONTINUE:
Next shp

End Sub

'**********************************************************************************************

'行か列の要素が増減されたので反映

Public Sub Change_RowCol_Count(ByVal lCount As Long, Optional ByVal bRow As Boolean = True)

If bRow = True Then
m_lRow_DataED = m_lRow_DataED + lCount
m_lRow_Last = m_lRow_DataED
m_lRow_DataCount = m_lRow_DataED - m_lRow_DataST + 1
Else
m_lCol_DataED = m_lCol_DataED + lCount
m_lCol_Last = m_lCol_DataED
m_lCol_DataCount = m_lCol_DataED - m_lCol_DataST + 1
End If

End Sub

'**********************************************************************************************

'結合セル対応の為、空なら上を探して値を返す

Public Function Get_CellValue_for_MergeCell(ByVal lRowST As Long, ByVal lColNo As Long) As String

Dim i As Long
Dim str As String

Get_CellValue_for_MergeCell = ""
i = lRowST
Do While i > 0
str = CStr(m_varAry(lColNo, i))
If str <> "" Then
Get_CellValue_for_MergeCell = str
Exit Function
End If
i = i - 1
Loop

End Function

'**********************************************************************************************

'ウィンドウ枠固定

Public Sub Set_FreezePanes(Optional ByVal lRow As Long = 0, Optional ByVal lCol As Long = 0)

Dim i As Long
Dim str As String
Dim rng As Range

If lRow <= 0 And lCol <= 0 Then Exit Sub
With m_wsSheet
If lRow > 0 And lCol > 0 Then
Set rng = .Cells(lRow, lCol)
ElseIf lRow > 0 Then
Set rng = .Rows(lRow)
ElseIf lCol > 0 Then
Set rng = .Columns(lCol)
End If
End With

str = Application.ActiveWorkbook.Name
i = Application.ActiveSheet.index

Call m_wsSheet.Activate
Call rng.Select
ActiveWindow.FreezePanes = True
Call m_wsSheet.Cells(1, 1).Select

Application.Workbooks(str).Sheets(i).Activate

End Sub

'**********************************************************************************************

'ウィンドウに表示されるビュー変更

Public Sub Change_WindowView(Optional ByVal WV As XlWindowView = xlPageBreakPreview, _
Optional ByVal lRow As Long = -1, Optional ByVal lCol As Long = -1)

Dim i As Long
Dim str As String

str = Application.ActiveWorkbook.Name
i = Application.ActiveSheet.index

With m_wsSheet
Call .Activate
'横向き
.PageSetup.Orientation = xlPortrait
'1ページに収める
.PageSetup.Zoom = False
.PageSetup.FitToPagesTall = 1
.PageSetup.FitToPagesWide = 1

Call .ResetAllPageBreaks

If lRow > 0 And lCol > 0 Then
.Cells(lRow, lCol).PageBreak = xlPageBreakManual
End If
End With
ActiveWindow.View = WV

Application.Workbooks(str).Sheets(i).Activate

End Sub

'**********************************************************************************************

'拡大率をシートに設定

Public Sub Set_ZoomSize(ByVal lZoomSize As Long)

Dim i As Long
Dim str As String

str = Application.ActiveWorkbook.Name
i = Application.ActiveSheet.index

Call m_wsSheet.Activate
ActiveWindow.Zoom = lZoomSize

Application.Workbooks(str).Sheets(i).Activate

End Sub

'**********************************************************************************************

'メンバシートにオートフィット

Public Sub Set_AutoFit()

Dim rng As Range
With m_wsSheet
Set rng = .Range(.Cells(Me.Row_Table_ST, Me.Col_Table_ST), .Cells(Me.Row_Last, Me.Col_Last))
End With
Call rng.Rows.AutoFit
Call rng.Columns.AutoFit

End Sub

'**********************************************************************************************

'行か列の幅を設定

Public Sub Set_CellSize(ByVal lSize As Long, ByVal lST As Long, ByVal lED As Long, _
Optional ByVal bDirection_Row As Boolean = True)

With m_wsSheet
If bDirection_Row = True Then
.Range(.Cells(lST, 1), .Cells(lED, 1)).EntireRow.RowHeight = lSize
Else
.Range(.Cells(1, lST), .Cells(1, lED)).EntireColumn.ColumnWidth = lSize
End If
End With

End Sub

'**********************************************************************************************