★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」になり、
つまり、調べたセルのアドレスと、結合されたセル範囲の左半分（「:」よりも左）が一致すれば、
そのセルからが、「結合のスタート」ということになります。
（逆に言うと、左半分のアドレスが一致しないセルは結合のスタートのセルではない・・・、ということになります。）
そして、冒頭にも述べました通り、
「結合（マージ）されたセルのうち、先頭のセルに「値」が格納される」ということなので、
セルの値も同時にゲットできます。
その性質を利用します。
|
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 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 ' ' ' ' |
- 投稿タグ
- ExcelVBA, Excelの独学, Excel連携VBA, ビジネスパソコンの基礎, マクロ, 独学, 自動化
