★★★★★★Access2000VBA・Excel2000VBA独学～例えば、セル結合もある、「３行単位で１レコード」の帳票を、１行１レコードの一覧表に変換する若干汎用的なプログラム～

★★★★★★Access2000VBA・Excel2000VBA独学～例えば、セル結合もある、「３行単位で１レコード」の帳票を、１行１レコードの一覧表に変換する若干汎用的なプログラム～
　　
※まだ書きかけです。すみません。
※間違ってたらすみません。
※メモ書きなので、自分でも意味不明な箇所も多いです。ごめんなさい。
　　
ご注意！！
列名（項目名）の処理が完全ではないので、プログラム実行後に、自分で列名のセルだけ正しい列に移動させる必要があります。あるいは、そこをご自分でプログラム化してみてください。
　　
※関連記事
『 ★★★★★★Access2000VBA・Excel2000VBA独学～結合セルの最初のセルと最後のセルのアドレス（番地）を調べる自作関数～請求書の「明細データ」などの、「結合されたセルを持つ帳票」のセルデータをテーブルデータなどに整形・クレンジング（？）するときなどに。～』

　　
　　
★ サンプルファイルダウンロード

こちらからダウンロードしてください。

Esetでウィルスチェックしてあります。

ファイルを開いたら、Alt＋F11 でVBEditorを開きます。
その中の「使用する_本番」というモジュールをダブルクリックすると、一番上の、tes007()というプロシージャで動きを確認できます。

「'★ 設定部」の「i_flg01 = 1」を「i_flg01 = 0」に変えると、「ヨコ展開の下蓄積の動き」から、「縦展開の右蓄積の動き」に変わります。

動きが遅い場合は「Application.ScreenUpdating = False」を追記するなどしてください。

　　
　　
★ はじめに

という、ある意味メチャクチャな表・・・・。

それを本記事のコードで以下のような一覧表にします。

あるいは

という形にします。

列名のセル結合の状態が、データ部分の状態と同じではないので、転記完了後に列名を整形しないといけません。

ただ、それであっても、いちおう、列名も（セル結合してあっても）転記できます。

セル結合の状態が多少規則正しくなくても「一度に処理する数行の中の項目数」が同じで、また、もちろん一度に処理する行数がすべて同じ帳票なら、基本的にはこのプログラムで処理できると思います。

そのような表に限っては、VBAにそこそこ慣れている方なら、パワークエリの「変換」？のようなものを使うよりも早いと思います。

ただ、「前ゼロ」のようなものの処理ができないままなので、そういうデータの場合は、別の関数を作ったり、条件分岐を増やしたりする必要があります。

'
'
'##############################################################################
'指定したセルの位置から、指定したフラグによって、
'縦にも、横にもセルに出力。GetMrgCelAddr_Fst関数も利用。
'##############################################################################

Sub tes007()

    Dim i_flg01         As Integer  '転記を横展開にするか、縦展開にするかの分岐のための条件となるフラグ用の変数。
    Dim o_Rng01         As Range    '帳票側のデータ（転記元のモトデータ）を指定するためのオブジェクト変数。
    Dim o_MiniRng01     As Range    '「××行ごと」のセル範囲を指定するためのオブジェクト変数。
    Dim o_TrgRng01      As Range    '転記先の最初のセルを指定するためのオブジェクト変数。
    Dim o_1Cel          As Range    '「××行ごと」のセル範囲＝ミニセル範囲の中のセル1個1個を、For Each 文で受けるためのオブジェクト変数。
    Dim l_1RecRowNum    As Long     '「××行ごと」を、実際に何行ごとにするかを指定するための変数。
    Dim l_RepeatNum     As Long     '帳票側のデータ（転記元のモトデータ）の中で、「××行ごと」の処理を何回繰り返せばいいかを算出するための変数。
    Dim i               As Long     '「××行ごと」の処理をループする際に、「どのようにズレるか？」を指定するための変数。
    Dim j               As Long     '転記先の列または行を指定するための変数。
    Dim k               As Long     '同上
    Dim v_aa            As Variant  'セルの値を操作するために、一時的にその値を格納するための変数。今回は特に何もしないけど、
                                    '    今後もしかしたら値を加工する必要性が出るかもしれないので、
                                    '    一応、そのときのために、使っておく。

    
    '★ 設定部
    
    i_flg01 = 1         '1は横展開で下方向にレコードを転記・蓄積。
                        '0は縦展開で右方向にレコードを転記・蓄積。
                        
    j = 1               'いちおう初期化。転記先のセルの指定に使います。
                        'ｊとｋ、どちらが列でどちらが行になるのかは、
                        '「i_flg01」の値によって変わります。
                        
    k = 1               '同上。
    
    l_1RecRowNum = 3    '帳票データの中を、何行ずつ処理するかの設定。
                        '（今回の例では３行ずつ処理するので「３」と指定。）
                        '（４行ずつ処理するなら「４」と指定。）
    
    
    Set o_Rng01 = Application. _
                   ActiveWorkbook. _
                    ActiveSheet. _
                     Range("A1:AN36")
    '↑帳票の範囲（チェックモトの全体範囲）を指定
    
    
    
    Set o_TrgRng01 = Application. _
                      ActiveWorkbook. _
                       ActiveSheet. _
                        Range("AP2")
    '↑ 転記先の最初のセル（起点）を指定。
    '  Range.RangeプロパティやRange.Cellsプロパティは起点セルからの相対的なセルを指定できます。
    '  今回はループの中で、転記先のセルを指定するために、
    '  Range.Rangeプロパティではなく、Range.Cellsプロパティを使います。

              
    
    l_RepeatNum = o_Rng01.Rows.Count / l_1RecRowNum - 1
    '↑「××行ごと」にループを繰り返す、「その回数」を算出。
    '  「-1」するのは、のちのOffset関数にて一番最初のループだけは
    '  「Offset(0,0)」と指定したいので
    '   そのからみで事前に「-1」しておきます。
    '   （For i =・・・の「i」の値を「0」から始めたいので、-1してない・普通に
    '     計算した値を使うと、ループ回数が１回分多くなってしまうため。）  
    
    
    Application.ActiveWorkbook.ActiveSheet.Range("AP2:BK15").ClearContents
    '↑いちおう今回のサンプルのみのコード。不要ならコメントアウトする。
    '  転記先をいったん空白にする。
    
    
  
  
    '★ 実動部
    
    For i = 0 To l_RepeatNum   '３行ずつを繰り返すループ。
    
    
        Set o_MiniRng01 = o_Rng01.Range("A1:AK3").Offset(l_1RecRowNum * i, 0)
        '↑３行ずつを「ミニ・セル範囲」として順番に処理していきたいので
        '  その３行ずつを操作対象としてセットしなおす処理。
        ' 「３行ずつ」は、「l_1RecRowNum」で指定しています。
        '  ※Offset関数の性質として、「Offset(0,0)」と指定すると、
        '    ズレない範囲（ここでは列名の３行分の範囲）を処理してくれるようなので、
        '    ここではその性質を使います。
        '    そのため、For のところでも「・・・ 0 to l_RepeatNum」と「ゼロ」を使っています。
        
        
        Debug.Print "★=================★"
        Debug.Print i
        Debug.Print o_Rng01.Range("A1:AK3").Address
        Debug.Print o_MiniRng01.Address
        Debug.Print "  ================="


        '
        For Each o_1Cel In o_MiniRng01    '「ミニ・セル範囲」の中のすべてのセルをチェックするループ。
        
            If o_1Cel.Address = GetMrgCelAddr_Fst(o_1Cel) Then
            
                Debug.Print o_1Cel.Value
                v_aa = o_1Cel.Value
                
                                
                If i_flg01 = 1 Then
'                    If v_aa = 2 Then Stop
                    o_TrgRng01.Cells(k, j) = v_aa  '横展開で下へ転記・蓄積していく。
                    
                ElseIf i_flg01 = 0 Then
                
                    o_TrgRng01.Cells(j, k) = v_aa  '縦展開で右へ転記・蓄積していく。
                    
                Else
                
                End If
                '↑フラグによって、横展開か縦展開かを処理し分ける。
                
                j = j + 1  '転記先セルを指定するために、インクリメント。
                           '（「ｊ」が行なのか列なのかはフラグの１か０かによって変わる。）
                
            Else
            
            End If
            
        Next o_1Cel
        '↑「ミニ・セル範囲」の中のすべてのセルをチェックするループ。
        
       
       
'        'データが転記される位置がガタガタになるダメなIF条件を使った失敗ループ。使用禁止。
'        For Each o_1Cel In o_MiniRng01
'            If o_1Cel.Value <> "" Or o_1Cel.Column = 24 Then
'                Debug.Print o_1Cel.Value
'                o_TrgRng01.Cells(j, k) = o_1Cel.Value
'                j = j + 1
'            Else
'
'            End If
'        Next o_1Cel

               
        
        Set o_MiniRng01 = Nothing    'チェックし終わったらいったん「ミニ・セル範囲（今の３行分）」を操作対象から外す。
        k = k + 1  '次のレコード（＝次の３行＝次のミニ・セル範囲）に移動するので、インクリメントするのみとする。
        j = 1      '「次のミニ・セル範囲」の「最初のセルから全部チェックし直さないといけない」ので、ここでもいったん初期化。
        
    Next i
    '↑３行ずつを繰り返すループ。
    
    
    
End Sub

'##############################################################################
'指定したセルの位置から下方向へ、横にセルに出力。GetMrgCelAddr_Fst関数も利用。
'tes005()とは、「o_TrgRng01.Cells(k, j) = v_aa」の行以外は全部同じ。
'o_TrgRng01.Cells(k, j) = v_aa」の k とj の位置が入れ替わっているだけ。
'##############################################################################

Sub tes006()

    Dim o_Rng01 As Range
    Dim o_MiniRng01 As Range
    Dim o_TrgRng01 As Range
    Dim o_1Cel As Range
    Dim l_HdrRowNum As Long
    Dim l_CrntRow As Long
    Dim i As Long
    Dim j As Long
    Dim k As Long
    Dim v_aa As Variant
    
    Set o_Rng01 = Application.ActiveWorkbook.ActiveSheet.Range("A1:AN36")
    Set o_TrgRng01 = Application.ActiveWorkbook.ActiveSheet.Range("AP2")
    
    Application.ActiveWorkbook.ActiveSheet.Range("AP2:BK15").ClearContents
'    l_HdrRowNum = 3
    
    j = 1
    k = 1
    
    For i = 0 To 11
    
        Debug.Print "★=================★"
        Debug.Print i
        Debug.Print o_Rng01.Range("A1:AK3").Address
        Set o_MiniRng01 = o_Rng01.Range("A1:AK3").Offset(3 * i, 0)
        Debug.Print o_MiniRng01.Address
        Debug.Print "  ================="

        For Each o_1Cel In o_MiniRng01
            If o_1Cel.Address = GetMrgCelAddr_Fst(o_1Cel) Then
                Debug.Print o_1Cel.Value
                
                v_aa = o_1Cel.Value
'                If v_aa = "1" Then Stop
                o_TrgRng01.Cells(k, j) = v_aa
                j = j + 1
            Else
            
            End If
        Next o_1Cel
        
       
'        'データが転記される位置がガタガタになるダメなIFを使った失敗ループ。使用禁止。
'        For Each o_1Cel In o_MiniRng01
'            If o_1Cel.Value <> "" Or o_1Cel.Column = 24 Then
'                Debug.Print o_1Cel.Value
'                o_TrgRng01.Cells(j, k) = o_1Cel.Value
'                j = j + 1
'            Else
'
'            End If
'        Next o_1Cel
               
        
        Set o_MiniRng01 = Nothing
        k = k + 1
        j = 1
        
    Next i
    
    
    
End Sub

'##############################################################################
'指定したセルの位置から右方向へ、縦にセルに出力。GetMrgCelAddr_Fst関数も利用。
'tes006()とは、「o_TrgRng01.Cells(k, j) = v_aa」の行以外は全部同じ。
'o_TrgRng01.Cells(k, j) = v_aa」の k とj の位置が入れ替わっているだけ。
'##############################################################################

Sub tes005()

    Dim o_Rng01 As Range
    Dim o_MiniRng01 As Range
    Dim o_TrgRng01 As Range
    Dim o_1Cel As Range
    Dim l_HdrRowNum As Long
    Dim l_CrntRow As Long
    Dim i As Long
    Dim j As Long
    Dim k As Long
    
    Set o_Rng01 = Application.ActiveWorkbook.ActiveSheet.Range("A1:AN36")
    Set o_TrgRng01 = Application.ActiveWorkbook.ActiveSheet.Range("AP2")
    Application.ActiveWorkbook.ActiveSheet.Range("AP2:BK15").ClearContents
'    l_HdrRowNum = 3
    
    j = 1
    k = 1
    
    For i = 0 To 11
    
        Debug.Print "★=================★"
        Debug.Print i
        Debug.Print o_Rng01.Range("A1:AK3").Address
        Set o_MiniRng01 = o_Rng01.Range("A1:AK3").Offset(3 * i, 0)
        Debug.Print o_MiniRng01.Address
        Debug.Print "================="

        For Each o_1Cel In o_MiniRng01
            If o_1Cel.Address = GetMrgCelAddr_Fst(o_1Cel) Then
                Debug.Print o_1Cel.Value
                o_TrgRng01.Cells(j, k) = o_1Cel.Value
                j = j + 1
            Else
            
            End If
        Next o_1Cel
        
'        'データが転記される位置がガタガタになるダメなIFを使った失敗ループ。使用禁止。
'        For Each o_1Cel In o_MiniRng01
'            If o_1Cel.Value <> "" Or o_1Cel.Column = 24 Then
'                Debug.Print o_1Cel.Value
'                o_TrgRng01.Cells(j, k) = o_1Cel.Value
'                j = j + 1
'            Else
'
'            End If
'        Next o_1Cel
               
        
        Set o_MiniRng01 = Nothing
        k = k + 1
        j = 1
        
    Next i
    
    
    
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
 
 
 
'#################################################################
'特定の、指定した文字を境に、その左側の文字列を切り出す自作関数
'今回は「$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


'
'

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

157

158

159

160

161

162

163

164

165

166

167

168

169

170

171

172

173

174

175

176

177

178

179

180

181

182

183

184

185

186

187

188

189

190

191

192

193

194

195

196

197

198

199

200

201

202

203

204

205

206

207

208

209

210

211

212

213

214

215

216

217

218

219

220

221

222

223

224

225

226

227

228

229

230

231

232

233

234

235

236

237

238

239

240

241

242

243

244

245

246

247

248

249

250

251

252

253

254

255

256

257

258

259

260

261

262

263

264

265

266

267

268

269

270

271

272

273

274

275

276

277

278

279

280

281

282

283

284

285

286

287

288

289

290

291

292

293

294

295

296

297

298

299

300

301

302

303

304

305

306

307

308

309

310

311

312

313

314

315

316

317

318

319

320

321

322

323

324

325

326

327

328

329

330

331

332

333

334

335

336

337

338

'##############################################################################

'指定したセルの位置から、指定したフラグによって、

'縦にも、横にもセルに出力。GetMrgCelAddr_Fst関数も利用。

'##############################################################################

Sub tes007()

Dim i_flg01 As Integer '転記を横展開にするか、縦展開にするかの分岐のための条件となるフラグ用の変数。

Dim o_Rng01 As Range '帳票側のデータ（転記元のモトデータ）を指定するためのオブジェクト変数。

Dim o_MiniRng01 As Range '「××行ごと」のセル範囲を指定するためのオブジェクト変数。

Dim o_TrgRng01 As Range '転記先の最初のセルを指定するためのオブジェクト変数。

Dim o_1Cel As Range '「××行ごと」のセル範囲＝ミニセル範囲の中のセル1個1個を、For Each 文で受けるためのオブジェクト変数。

Dim l_1RecRowNum As Long '「××行ごと」を、実際に何行ごとにするかを指定するための変数。

Dim l_RepeatNum As Long '帳票側のデータ（転記元のモトデータ）の中で、「××行ごと」の処理を何回繰り返せばいいかを算出するための変数。

Dim i As Long '「××行ごと」の処理をループする際に、「どのようにズレるか？」を指定するための変数。

Dim j As Long '転記先の列または行を指定するための変数。

Dim k As Long '同上

Dim v_aa As Variant 'セルの値を操作するために、一時的にその値を格納するための変数。今回は特に何もしないけど、

' 今後もしかしたら値を加工する必要性が出るかもしれないので、

' 一応、そのときのために、使っておく。

'★ 設定部

i_flg01 = 1 '1は横展開で下方向にレコードを転記・蓄積。

'0は縦展開で右方向にレコードを転記・蓄積。

j = 1 'いちおう初期化。転記先のセルの指定に使います。

'ｊとｋ、どちらが列でどちらが行になるのかは、

'「i_flg01」の値によって変わります。

k = 1 '同上。

l_1RecRowNum = 3 '帳票データの中を、何行ずつ処理するかの設定。

'（今回の例では３行ずつ処理するので「３」と指定。）

'（４行ずつ処理するなら「４」と指定。）

Set o_Rng01 = Application. _

ActiveWorkbook. _

ActiveSheet. _

Range("A1:AN36")

'↑帳票の範囲（チェックモトの全体範囲）を指定

Set o_TrgRng01 = Application. _

ActiveWorkbook. _

ActiveSheet. _

Range("AP2")

'↑ 転記先の最初のセル（起点）を指定。

' Range.RangeプロパティやRange.Cellsプロパティは起点セルからの相対的なセルを指定できます。

' 今回はループの中で、転記先のセルを指定するために、

' Range.Rangeプロパティではなく、Range.Cellsプロパティを使います。

l_RepeatNum = o_Rng01.Rows.Count / l_1RecRowNum - 1

'↑「××行ごと」にループを繰り返す、「その回数」を算出。

' 「-1」するのは、のちのOffset関数にて一番最初のループだけは

' 「Offset(0,0)」と指定したいので

' そのからみで事前に「-1」しておきます。

' （For i =・・・の「i」の値を「0」から始めたいので、-1してない・普通に

' 計算した値を使うと、ループ回数が１回分多くなってしまうため。）

Application.ActiveWorkbook.ActiveSheet.Range("AP2:BK15").ClearContents

'↑いちおう今回のサンプルのみのコード。不要ならコメントアウトする。

' 転記先をいったん空白にする。

'★ 実動部

For i = 0 To l_RepeatNum '３行ずつを繰り返すループ。

Set o_MiniRng01 = o_Rng01.Range("A1:AK3").Offset(l_1RecRowNum * i, 0)

'↑３行ずつを「ミニ・セル範囲」として順番に処理していきたいので

' その３行ずつを操作対象としてセットしなおす処理。

' 「３行ずつ」は、「l_1RecRowNum」で指定しています。

' ※Offset関数の性質として、「Offset(0,0)」と指定すると、

' ズレない範囲（ここでは列名の３行分の範囲）を処理してくれるようなので、

' ここではその性質を使います。

' そのため、For のところでも「・・・ 0 to l_RepeatNum」と「ゼロ」を使っています。

Debug.Print "★=================★"

Debug.Print i

Debug.Print o_Rng01.Range("A1:AK3").Address

Debug.Print o_MiniRng01.Address

Debug.Print " ================="

For Each o_1Cel In o_MiniRng01 '「ミニ・セル範囲」の中のすべてのセルをチェックするループ。

If o_1Cel.Address = GetMrgCelAddr_Fst(o_1Cel) Then

Debug.Print o_1Cel.Value

v_aa = o_1Cel.Value

If i_flg01 = 1 Then

' If v_aa = 2 Then Stop

o_TrgRng01.Cells(k, j) = v_aa '横展開で下へ転記・蓄積していく。

ElseIf i_flg01 = 0 Then

o_TrgRng01.Cells(j, k) = v_aa '縦展開で右へ転記・蓄積していく。

Else

End If

'↑フラグによって、横展開か縦展開かを処理し分ける。

j = j + 1 '転記先セルを指定するために、インクリメント。

'（「ｊ」が行なのか列なのかはフラグの１か０かによって変わる。）

Else

End If

Next o_1Cel

'↑「ミニ・セル範囲」の中のすべてのセルをチェックするループ。

' 'データが転記される位置がガタガタになるダメなIF条件を使った失敗ループ。使用禁止。

' For Each o_1Cel In o_MiniRng01

' If o_1Cel.Value <> "" Or o_1Cel.Column = 24 Then

' Debug.Print o_1Cel.Value

' o_TrgRng01.Cells(j, k) = o_1Cel.Value

' j = j + 1

' Else

' End If

' Next o_1Cel

Set o_MiniRng01 = Nothing 'チェックし終わったらいったん「ミニ・セル範囲（今の３行分）」を操作対象から外す。

k = k + 1 '次のレコード（＝次の３行＝次のミニ・セル範囲）に移動するので、インクリメントするのみとする。

j = 1 '「次のミニ・セル範囲」の「最初のセルから全部チェックし直さないといけない」ので、ここでもいったん初期化。

Next i

'↑３行ずつを繰り返すループ。

End Sub

'##############################################################################

'指定したセルの位置から下方向へ、横にセルに出力。GetMrgCelAddr_Fst関数も利用。

'tes005()とは、「o_TrgRng01.Cells(k, j) = v_aa」の行以外は全部同じ。

'o_TrgRng01.Cells(k, j) = v_aa」の k とj の位置が入れ替わっているだけ。

'##############################################################################

Sub tes006()

Dim o_Rng01 As Range

Dim o_MiniRng01 As Range

Dim o_TrgRng01 As Range

Dim o_1Cel As Range

Dim l_HdrRowNum As Long

Dim l_CrntRow As Long

Dim i As Long

Dim j As Long

Dim k As Long

Dim v_aa As Variant

Set o_Rng01 = Application.ActiveWorkbook.ActiveSheet.Range("A1:AN36")

Set o_TrgRng01 = Application.ActiveWorkbook.ActiveSheet.Range("AP2")

Application.ActiveWorkbook.ActiveSheet.Range("AP2:BK15").ClearContents

' l_HdrRowNum = 3

j = 1

k = 1

For i = 0 To 11

Debug.Print "★=================★"

Debug.Print i

Debug.Print o_Rng01.Range("A1:AK3").Address

Set o_MiniRng01 = o_Rng01.Range("A1:AK3").Offset(3 * i, 0)

Debug.Print o_MiniRng01.Address

Debug.Print " ================="

For Each o_1Cel In o_MiniRng01

If o_1Cel.Address = GetMrgCelAddr_Fst(o_1Cel) Then

Debug.Print o_1Cel.Value

v_aa = o_1Cel.Value

' If v_aa = "1" Then Stop

o_TrgRng01.Cells(k, j) = v_aa

j = j + 1

Else

End If

Next o_1Cel

' 'データが転記される位置がガタガタになるダメなIFを使った失敗ループ。使用禁止。

' For Each o_1Cel In o_MiniRng01

' If o_1Cel.Value <> "" Or o_1Cel.Column = 24 Then

' Debug.Print o_1Cel.Value

' o_TrgRng01.Cells(j, k) = o_1Cel.Value

' j = j + 1

' Else

' End If

' Next o_1Cel

Set o_MiniRng01 = Nothing

k = k + 1

j = 1

Next i

End Sub

'##############################################################################

'指定したセルの位置から右方向へ、縦にセルに出力。GetMrgCelAddr_Fst関数も利用。

'tes006()とは、「o_TrgRng01.Cells(k, j) = v_aa」の行以外は全部同じ。

'o_TrgRng01.Cells(k, j) = v_aa」の k とj の位置が入れ替わっているだけ。

'##############################################################################

Sub tes005()

Dim o_Rng01 As Range

Dim o_MiniRng01 As Range

Dim o_TrgRng01 As Range

Dim o_1Cel As Range

Dim l_HdrRowNum As Long

Dim l_CrntRow As Long

Dim i As Long

Dim j As Long

Dim k As Long

Set o_Rng01 = Application.ActiveWorkbook.ActiveSheet.Range("A1:AN36")

Set o_TrgRng01 = Application.ActiveWorkbook.ActiveSheet.Range("AP2")

Application.ActiveWorkbook.ActiveSheet.Range("AP2:BK15").ClearContents

' l_HdrRowNum = 3

j = 1

k = 1

For i = 0 To 11

Debug.Print "★=================★"

Debug.Print i

Debug.Print o_Rng01.Range("A1:AK3").Address

Set o_MiniRng01 = o_Rng01.Range("A1:AK3").Offset(3 * i, 0)

Debug.Print o_MiniRng01.Address

Debug.Print "================="

For Each o_1Cel In o_MiniRng01

If o_1Cel.Address = GetMrgCelAddr_Fst(o_1Cel) Then

Debug.Print o_1Cel.Value

o_TrgRng01.Cells(j, k) = o_1Cel.Value

j = j + 1

Else

End If

Next o_1Cel

' 'データが転記される位置がガタガタになるダメなIFを使った失敗ループ。使用禁止。

' For Each o_1Cel In o_MiniRng01

' If o_1Cel.Value <> "" Or o_1Cel.Column = 24 Then

' Debug.Print o_1Cel.Value

' o_TrgRng01.Cells(j, k) = o_1Cel.Value

' j = j + 1

' Else

' End If

' Next o_1Cel

Set o_MiniRng01 = Nothing

k = k + 1

j = 1

Next i

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

'#################################################################

'特定の、指定した文字を境に、その左側の文字列を切り出す自作関数

'今回は「$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

MENU

関連記事

最近の投稿

カテゴリー

MENU

★★★★★★Access2000VBA・Excel2000VBA独学～例えば、セル結合もある、「３行単位で１レコード」の帳票を、１行１レコードの一覧表に変換する若干汎用的なプログラム～

関連記事

最近の投稿

カテゴリー

タグ