Option Explicit

'//Selection_CurrentRegion_Absolute()Selection_CurrentRegion_Relative()Ť
'//͈̗ٔ͂񕝂@ꍇͤTrue ̍sLɂ
'//͈̗ٔ͂񕝂ȂꍇͤFalse̍sLɂ
'Private Const bAutoFit As Boolean = True
Private Const bAutoFit As Boolean = False

'//Excel2010_Absolute_Transpose_Paste_Bug_WorkaroundŎgp餈ꎞIܰޯ
'//ϸۂsxɐVܰޯ쐬ɤŏ̈񂾂쐬邱Ƃɂ
Private wbTmp As Workbook

'//IĂ̈̍sԍدްނɓ
'//قҲݳ޳̤[°][ϸ][ϸ][߼]ŤCtrl+jɊ蓖ĂĂ
'//DataObjectgpɂ͢Microsoft Forms 2.0 Object Libraryւ̎QƂKvł
'//QƉ\ײ̧٣̒ɢMicrosoft Forms 2.0 Object Libraryꍇͤ
'//C:\Windows\System32\FM20.DLL܂͢C:\Windows\SysWOW64\FM20.DLLQƂ
'//(ײ؂߽OSɂĈقȂ)
Public Sub Selection_PutInClipboard()
        Dim iRow_First As Long
        Dim iRow_Last As Long
        Dim iColumn_First As Long
        Dim iColumn_Last As Long
        Dim s As String
        Dim cb As New DataObject
        '//I͈͂̍ŏ͈̔͂Ώۂɂ
        With Selection.Areas(1)
                '//擪sԍƐ擪ԍ擾
                With .Cells(1, 1)
                        iRow_First = .Row
                        iColumn_First = .Column
                End With
                '//ŏIsԍ擾(擪sԍ+Is-1)
                iRow_Last = iRow_First + .Rows.Count - 1
                '//ŏIԍ擾(擪ԍ+I-1)
                iColumn_Last = iColumn_First + .Columns.Count - 1
        End With
        '//ʂدްނɓ
        s = iRow_First & vbTab & iColumn_First & vbTab & iRow_Last & vbTab & iColumn_Last
        cb.SetText s
        cb.PutInClipboard
        cb.GetFromClipboard
'//     MsgBox Replace(cb.GetText, vbTab, " ")  '//J̊mFp
End Sub

'//AްĂ͈̤ٔ͂̒Ύɂ
'//ϸۂgpԂͤEXCEL̢vZ@̐ݒ裂蓮ɂĂƂ߂顄~2014/08/26ǋL:L̓_ͤlȂėǂȂ܂
'//vZ@̐ݒ裂𢎩ɂꍇढ蓮ɂɎsł顄~Selection_CurrentRegion_Absolute_Relative()Ťè޼Ă̍ČvZꎞIɵ̂悤ɕύXł
'//܂ݸܰޯLꍇͤܰޯJĂƍɎsł顁dv
'//قҲݳ޳̤[°][ϸ][ϸ][߼]ŤCtrl+qɊ蓖ĂĂ
Public Sub Selection_CurrentRegion_Absolute()
        Selection_CurrentRegion_Absolute_Relative True
End Sub

'//AްĂ͈̤ٔ͂̒𑊑Ύɂ
'//ϸۂgpԂͤEXCEL̢vZ@̐ݒ裂蓮ɂĂƂ߂顄~2014/08/26ǋL:L̓_ͤlȂėǂȂ܂
'//vZ@̐ݒ裂𢎩ɂꍇढ蓮ɂɎsł顄~Selection_CurrentRegion_Absolute_Relative()Ťè޼Ă̍ČvZꎞIɵ̂悤ɕύXł
'//܂ݸܰޯLꍇͤܰޯJĂƍɎsł顁dv
'//قҲݳ޳̤[°][ϸ][ϸ][߼]ŤCtrl+eɊ蓖ĂĂ
Public Sub Selection_CurrentRegion_Relative()
        Selection_CurrentRegion_Absolute_Relative False
End Sub

'//Selection_CurrentRegion_AbsoluteSelection_CurrentRegion_Relative̋ʏ
Private Sub Selection_CurrentRegion_Absolute_Relative(ByVal bAbsolute As Boolean)
        Dim Rows As Range, r As Range
        Dim bComment As Boolean, bId As Boolean
        Dim s As String
        '//AްĂ͈ٔ͂I
        Selection.CurrentRegion.Select
        '//͈ٔ͂̐FؾĂ
        Selection.Interior.ColorIndex = xlColorIndexNone
        '//è޼Ă̍ČvẐɂ
        ActiveSheet.EnableCalculation = False
        '//͈ٔ͂̊esɂāc
        For Each Rows In Selection.Rows
                '//׸ނر
                bComment = False
                '//Iids׸ނر
                bId = False
                '//es̊eقɂāc
                For Each r In Rows.Cells
                        '//Ȃ΁c
                        If r.HasFormula Then
                                '//Selection_CurrentRegion_AbsoluteĂ΂ꂽꍇΎɕϊ
                                '//ޯ̼Ă⤓ޯ̼̑ĂQƂȂłꍇͤΎƂ
                                '//ႦΤޯ⼰Ăݸق̕тׂ̗ɤ=(2^16)-SUM(R[1]C:R[9]C)̂悤ȎuꍇͤΎ̂܂܂ɂł
                                If bAbsolute And InStr(r.Formula, "!") Then
                                        '//Ύɂ
                                        r.Formula = Application.ConvertFormula(Formula:=r.Formula, FromReferenceStyle:=xlA1, ToAbsolute:=xlAbsolute, RelativeTo:=r)
                                        '//IidsȂ΁c
                                                '//ق̐FFɐݒ肷
                                                r.Interior.ColorIndex = 27
                                        If bId Then
                                        '//IidsłȂ΁c
                                        Else
                                                '//ق̐F𔖂Fɐݒ肷
                                                r.Interior.ColorIndex = 19
                                        End If
                                '//Selection_CurrentRegion_RelativeĂ΂ꂽꍇΎɕϊ
                                Else
                                        '//Ύɂ
                                        r.Formula = Application.ConvertFormula(Formula:=r.Formula, FromReferenceStyle:=xlA1, ToAbsolute:=xlRelative, RelativeTo:=r)
                                        '//IidsȂ΁c
                                                '//ق̐FFɐݒ肷
                                                r.Interior.ColorIndex = 28
                                        If bId Then
                                        '//IidsłȂ΁c
                                        Else
                                                '//ق̐F𔖂Fɐݒ肷
                                                r.Interior.ColorIndex = 20
                                        End If
                                End If
                        '//łȂ΁c
                        Else
                                '//ق̒l𕶎ƂĎ擾
                                s = r.Value
                                '//ق̒l(0)ȂΤق̐FԐFɐݒ肷
                                If s = "" Then
                                        r.Interior.ColorIndex = 3
                                '//ق̒l(0ȏ)//(0ȏ)ȂΤ׸ނĂ
                                '//MkLotTbl.batE̾قQƂȂƂ邽ߡ
                                ElseIf s Like "*//*" Then
                                        bComment = True
                                        '//̌̏Ťق̐FԐFɐݒ肷
                                '//ق̒lid,,id(0ȏ)ȂΤIids׸ނĂ
                                '//MkLotTbl.bat̍s𢒊IidsƌȂƂ邽ߡ
                                ElseIf (s = "id") Or (s Like "id(*)") Then
                                        bId = True
                                        '//ق̐FFɐݒ肷
                                        r.Interior.ColorIndex = 45
                                '//ȊOȂ΁c
                                Else
                                        '//IidsȂ΁c
                                        If bId Then
                                                '//ق̐FDFɐݒ肷
                                                r.Interior.ColorIndex = 48
                                        '//IidsłȂ΁c
                                        Else
                                                '//ق̐F𔖂DFɐݒ肷
                                                r.Interior.ColorIndex = 15
                                        End If
                                End If
                        End If
                        '//׸ނĂĂ社ق̐FԐFŏ㏑
                        If bComment Then r.Interior.ColorIndex = 3
                Next
        Next
        '//è޼Ă̍ČvZ݂ɖ߂
        ActiveSheet.EnableCalculation = True
        '//͈ٔ͂̌rݒ肷
        Selection.Borders.LineStyle = xlContinuous
        '//͈̗ٔ͂񕝂ݒ肷
        If bAutoFit Then Selection.Columns.AutoFit
End Sub

'//݂̑I͈͂stɂĤꎞIܰĂݸݸدްނֺ߰܂
'// - Excel2010Ťݸ̾قstɂĒtƤݸĂ܂悤Ȃ̂ŤƂč쐬ϸۂł
'//   ϸۂgĈꎞIܰĂް쐬㤖ړIܰĂɒtĂ
'// - Ȃ݂Excel2000ȂΤLݸ͐Ȃ̂Ťϸۂg킸ʂ̑ōsĂvł
'//قҲݳ޳̤[°][ϸ][ϸ][߼]ŤCtrl+mɊ蓖ĂĂ
Public Sub Excel2010_Absolute_Transpose_Paste_Bug_Workaround()
        Dim wbSrc As Workbook
        Dim wsTmp As Worksheet
        Dim rSrc As Range
        Dim rTmp As Range
        Dim Row As Long
        Dim Col As Long
        '//݂ܰޯL
        Set wbSrc = ActiveWorkbook
        '//݂̑I͈͂擾
        Set rSrc = Selection.Areas(1)
        '//ꎞIܰĂ擾鏈񂩤łȂɂāc
        If wbTmp Is Nothing Then
                '//ȂΤꎞIܰޯ쐬čŏܰĂ擾
                Set wbTmp = Workbooks.Add
                Set wsTmp = wbTmp.Worksheets(1)
        Else
                '//łȂΤ̈ꎞIܰޯɐVKܰĂǉ
                '//ꎞIܰޯĂꍇͤwbTmp.Worksheets.AddװɂȂ̂ŤꎞIܰޯč쐬
                On Error Resume Next
                Set wsTmp = wbTmp.Worksheets.Add
                If Err.Number Then
                        Set wbTmp = Workbooks.Add
                        Set wsTmp = wbTmp.Worksheets(1)
                End If
                On Error GoTo 0
        End If
        '//ꎞIܰޯèނɂ顂ȂƤSelects悤
        wbTmp.Activate
        '//ꎞIܰĂَ̾QƂ擾
        Set rTmp = wsTmp.Cells
        '//ꎞIܰĂ̍ČvẐɂ    '//ϸۂłͤ̑΍sĂA܂荂
        wsTmp.EnableCalculation = False         '//ʂ悤ꉞsĂƂɂ
        '//I͈͂̊eقɂāc
        For Row = 1 To rSrc.Rows.Count
                For Col = 1 To rSrc.Columns.Count
                        '//I͈͂߰
                        rSrc(Row, Col).Copy
                        '//ꎞIܰĂ̤stɂقI
                        rTmp(Col, Row).Select
                        '//ݸ\t
                        '//ݸ\tꍇͤ̂悤ɤ\ݸ\tSelectĂKvL
                        wsTmp.Paste Link:=True
                Next
        Next
        '//ꎞIܰĂ̍ČvZ݂ɖ߂    '//ϸۂłͤ̑΍sĂA܂荂
        wsTmp.EnableCalculation = True          '//ʂ悤ꉞsĂƂɂ
        '//ݸ\t͈͂I
        Selection.CurrentRegion.Select
        '//ݸ\t͈͂߰
        Selection.CurrentRegion.Copy
        '//ܰޯèނɂ
        wbSrc.Activate
End Sub

'//è޼đŜɑ΂ĤSelection_CurrentRegion_Absolutes
'//ϸۂͤƒɎԂȂ߂ɤō̂ł
'//Ķķ͊蓖ĂȂɂExcelϸƭsĂ
'//pɂɌJԂgł傤
Public Sub ActiveSheet_Absolute()
        Dim Ws As Worksheet
        Dim r As Range
        Dim Row As Long, Cnt As Long
        Set Ws = ActiveSheet
        Set r = Ws.Cells
        Row = 1
        Ws.EnableCalculation = False
        Do
                Cnt = 0
                Do
                        If r(Row, 1) <> "" Then Exit Do
                        Row = Row + 1
                        Cnt = Cnt + 1
                        If Cnt > 999 Then
                                r(1, 1).Activate
                                MsgBox "܂", vbInformation Or vbOKOnly
                                Exit Sub
                        End If
                Loop
                r(Row, 1).Activate
                Selection_CurrentRegion_Absolute
                Do
                        If r(Row, 1) = "" Then Exit Do
                        Row = Row + 1
                Loop
        Loop
        Ws.EnableCalculation = True
End Sub

