'
'
Option Explicit
'
Sub test()
Dim o_SrcWS01 As Worksheet
Dim s_SrcCellStrtAddr As String
Dim s_SrcCellEndAddr As String
Dim o_SrcChkRng01 As Range
Dim o_1CelIem As Range
Dim s_MrgCellEndAddr As String
Dim o_TrgWS01 As Worksheet
Dim i_TrgCellGyouNum As Integer
'★結合されたセルのある列名の行の設定
s_SrcCellStrtAddr = "A1"
s_SrcCellEndAddr = "J1"
Set o_SrcWS01 = ActiveSheet
Set o_SrcChkRng01 = o_SrcWS01.Range(s_SrcCellStrtAddr & ":" & s_SrcCellEndAddr)
'★転記先シートの新設と設定
Set o_TrgWS01 = Worksheets.Add(after:=ActiveSheet)
i_TrgCellGyouNum = 1 '転記先のセルの「行」の指定に使います。
'セルアドレスは、「1」行目からなので、「ゼロ」はダメ。
'★メイン
For Each o_1CelIem In o_SrcChkRng01
'ソースのシートの「ミニ・セル範囲」の中のすべてのセルをチェックして
'新しいシートに転記するループ。
If o_1CelIem.Address = GetMrgCelAddr_Fst(o_1CelIem) Then
' Debug.Print o_1CelIem.Address & "---" & o_1CelIem.Value & "---" & s_MrgCellEndAddr
o_TrgWS01.Range("A" & i_TrgCellGyouNum) = o_1CelIem.Value
o_TrgWS01.Range("B" & i_TrgCellGyouNum) = o_1CelIem.Address(False, False)
If 2 <= i_TrgCellGyouNum Then
o_TrgWS01.Range("C" & i_TrgCellGyouNum - 1) = s_MrgCellEndAddr
Else
End If
i_TrgCellGyouNum = i_TrgCellGyouNum + 1
'転記先セルを指定するために、インクリメント。
'（「ｊ」が行なのか列なのかはフラグの１か０かによって変わる。）
ElseIf o_1CelIem.Address(False, False) = s_SrcCellEndAddr Then
o_TrgWS01.Range("C" & i_TrgCellGyouNum - 1) = s_SrcCellEndAddr
Else
Debug.Print o_1CelIem.Address
Let s_MrgCellEndAddr = o_1CelIem.Address(False, False)
End If
Next o_1CelIem
End Sub
'#################################################################
'結合セルの先頭セルのアドレスを取得する自作関数
'#################################################################
Function GetMrgCelAddr_Fst(o_SingleCel As Range) As String
Dim s_MargAddr As String
If o_SingleCel.MergeCells = True Then
s_MargAddr = o_SingleCel.MergeArea.Address
GetMrgCelAddr_Fst = LTrimWrd(s_MargAddr, ":")
Else
GetMrgCelAddr_Fst = "NonMrg"
End If
End Function
'#################################################################
'結合セルの最後のセルのアドレスを取得する自作関数
'#################################################################
Function GetMrgCelAddr_End(o_SingleCel As Range) As String
Dim s_MargAddr As String
If o_SingleCel.MergeCells = True Then
s_MargAddr = o_SingleCel.MergeArea.Address
GetMrgCelAddr_End = RTrimWrd(s_MargAddr, ":")
Else
GetMrgCelAddr_End = "NonMrg"
End If
End Function
'#################################################################
'特定の、指定した文字を境に、その左側の文字列を切り出す自作関数
'今回は「$A$1:$C$1」のようなセル範囲の「:」よりも左のアドレスを
'取得するのに使います
'#################################################################
Function LTrimWrd(s_Wrd01 As String, s_DlmtChr01 As String) As String
Dim i_DlmtPos As Integer
i_DlmtPos = InStr(1, s_Wrd01, s_DlmtChr01, vbBinaryCompare)
LTrimWrd = Left(s_Wrd01, i_DlmtPos - 1)
End Function
'#################################################################
'特定の、指定した文字を境に、その右側の文字列を切り出す自作関数
'今回は「$A$1:$C$1」のようなセル範囲の「:」よりも右のアドレスを取得
'するのに使います
'#################################################################
Function RTrimWrd(s_Wrd02 As String, s_DlmtChr02 As String) As String
Dim i_DlmtPos02 As Integer
Dim l_WdLen01 As Integer
l_WdLen01 = Len(s_Wrd02)
i_DlmtPos02 = InStr(1, s_Wrd02, s_DlmtChr02, vbBinaryCompare)
RTrimWrd = Right(s_Wrd02, l_WdLen01 - i_DlmtPos02)
End Function
'
'
'
'
