★ExcelVBA ～セル結合されてしまった列名（＝項目名）のセルアドレスと値を新規シートに転記する方法

★ExcelVBA ～セル結合されてしまった列名（＝項目名）のセルアドレスと値を新規シートに転記する方法
　　
※まだ書きかけです。すみません。
※間違ってたらすみません。
※メモ書きなので、自分でも意味不明な箇所も多いです。ごめんなさい。
　　
　　

結合（マージ）されたセルのうち、先頭のセルに「値」が格納されます。
また、Range.MergeAreaプロパティは、結合されたセル範囲（＝Rangeオブジェクト）を返してくれます。
例えば、「A1～C1の３つのセルが結合されていれば」、イミディエイトでは以下のようになります。

? Range("A1").MergeArea.address(false,false)
A1:C1

? Range("B1").MergeArea.address(false,false)
A1:C1

? Range("C1").MergeArea.address(false,false)
A1:C1

上記のように、結合された範囲の最初のセルは、どのセルで調べても全部、
「結合範囲の」「先頭のセル」になります。

なので、この場合だと、
Range("××").MergeArea.address の値が、
全部「A1:C1」になり、
つまり、調べたセルのアドレスと、結合されたセル範囲の左半分（「:」よりも左）が一致すれば、
そのセルからが、「結合のスタート」ということになります。
（逆に言うと、左半分のアドレスが一致しないセルは結合のスタートのセルではない・・・、ということになります。）

そして、冒頭にも述べました通り、
「結合（マージ）されたセルのうち、先頭のセルに「値」が格納される」ということなので、
セルの値も同時にゲットできます。
その性質を利用します。

'
'
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
'
'

'
'

100

101

102

103

104

105

106

107

108

109

110

111

112

113

114

115

116

117

118

119

120

121

122

123

124

125

126

127

128

129

130

131

132

133

134

135

136

137

138

139

140

141

142

143

144

145

146

147

148

149

150

151

152

153

154

155

156

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

MENU

関連記事

最近の投稿

カテゴリー

MENU

★ExcelVBA ～ セル結合されてしまった列名（＝項目名）のセルアドレスと値を新規シートに転記する方法

関連記事

最近の投稿

カテゴリー

タグ

★ExcelVBA ～セル結合されてしまった列名（＝項目名）のセルアドレスと値を新規シートに転記する方法