148:エクセル素材 下のセルとさらに下のセルの中身を合わせて右端までコピー

130:マクロ素材

会社の業務のなかで、IBMのデータベースからデータを落とすと、1行目から3行目にフィールド名が来ることが多いのですが、1行目の内容は無視しして、2行目と3行目のフィールド名を合わせて、フィールド名にすることで、他のソフトでの運用ができるようになるために、マクロを作成してみました。

結論

Sub 下のセルとさらにその下のセルを合体してコピー()
'
' 下のセルとさらにその下のセルを合体してコピー Macro
' 下のセルとさらにその下のセルを&で合体してコピー
' 列の最も右のセルまでコピーして値固定して、1行目2行目を削除
' Keyboard Shortcut: Ctrl+w
'
    ActiveCell.FormulaR1C1 = "=+R[1]C&R[2]C"
    Selection.Copy
    '現在の列を調べる
    現在セル番地 = ActiveCell.Address(ColumnAbsolute:=False, RowAbsolute:=False)
    現在のセル列 = Left(現在セル番地, 1)
    'MsgBox 現在のセル列
    '最後の列を調べる
    Dim 最右列番号 As Long
    Dim 最右列名 As String
    
    最右列番号 = ActiveSheet.UsedRange.Columns.Count
    最右列名 = ConvertToLetter(最右列番号) 'CovertTOLetter下の関数
        
    右までの範囲 = 現在のセル列 & "1:" & 最右列名 & "1"
    'MsgBox 右までの範囲

    Range(右までの範囲).Select
    ActiveSheet.Paste 'ここまでで計算式をコピー
    Application.CutCopyMode = False
    '以下は値コピー
    Selection.Copy
    コピー位置 = 現在のセル列 & 3
    Range(コピー位置).Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Application.CutCopyMode = False
   '1行目と2行目を削除する。
    Rows("1:2").Select
    Range("A2").Activate
    Selection.Delete Shift:=xlUp
    Range("A1").Select
End Sub

Function ConvertToLetter(iCol As Long) As String
    Dim a As Long
    Dim b As Long
    a = iCol
    ConvertToLetter = ""
    Do While iCol > 0
        a = Int((iCol - 1) / 26)
        b = (iCol - 1) Mod 26
        ConvertToLetter = Chr(b + 65) & ConvertToLetter
        iCol = a
    Loop
End Function

なお、functionについては、Microsoftの公式 ホームページから引用しております。

Excel の列番号をアルファベット文字に変換する方法 - Microsoft 365 Apps
この記事では、整数をアルファベット文字に変換する方法について説明します。

説明

一つのマクロと一つの計算マクロ式の2つで構成しております。

初めに

まず、エクセルで今あるセルに、+↓&↓と入力すると、以下となります。

ActiveCell.FormulaR1C1 = “=+R[1]C&R[2]C”

ActiveCell は、相対的に指定するということで、R[1]は現在から1行下 R[2]は2行下 Cは列でこの場合には変更なしです。

Selection.Copy

これは、コピーしたというものです。

次に現在の列を調べます。

‘現在の列を調べる

 現在セル番地 = ActiveCell.Address(ColumnAbsolute:=False, RowAbsolute:=False)

 現在のセル列 = Left(現在セル番地, 1)

 ’MsgBox 現在のセル列

は、まさしく、現在の列を調べているのですが、まず、現在のセル番地を調べて、その初めの1文字を取得しています。

それなので、現在のセルがAA列以上には、対応していないので、AA列より現在のセルが右にある場合には、エラーとなってしまい、このマクロは使用できません。

対応の方法は、あると思いますが、わたしの業務の中でAA列より右に現在のセルがあることのシチュエーションが無いので、このままとしてあります。

確認のために、MSGBOXで、確認した形跡が残っております。

最も右の列を調べます。今回のメインです。

‘最後の列を調べる

Dim 最右列番号 As Long  変数 最右列番号を数字型で宣言

Dim 最右列名 As String   変数 最右列名を文字列と宣言

最右列番号 = ActiveSheet.UsedRange.Columns.Count シート内の最も右のセル番号を取得

最右列名 = ConvertToLetter(最右列番号) ‘CovertTOLetter下の関数 右のセル番号を列名に変換

右までの範囲 = 現在のセル列 & “1:” & 最右列名 & “1” 現在のセルから最も右のセルまでの範囲を、右までの範囲とした

‘MsgBox 右までの範囲

上記の中で、ConvertToLetter()は、マクロ下部の Function ConvertToLetter(iCol As Long) As String ~ End Function

の関数を利用しております。このFunction関数は、Microsoftの「Excel列番号をアルファベットに変換する方法」そのままです。

貼付

上記で式をコピーしているので、右までの範囲に計算式を貼り付けます。

Range(右までの範囲).Select

  ActiveSheet.Paste ‘ここまでで計算式を貼り付け

Application.CutCopyMode = False コピーモードをキャンセル

値貼り付け

‘以下は値コピー

Selection.Copy

コピー位置 = 現在のセル列 & 3 ’私の場合には3行目に合体したフィールド名を入れるので3

Range(コピー位置).Select

Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _

:=False, Transpose:=False Application.CutCopyMode = False ’値貼付

Application.CutCopyMode = False

不要な1行目と2行目を削除する。

‘1行目と2行目を削除する。

Rows(“1:2”).Select

Range(“A2”).Activate ‘これは、不要

Selection.Delete Shift:=xlUp ’行削除して列を上へ詰めるという命令

最後にA1に戻って終了

Range(“A1”).Select

という内容でした。

コメント

タイトルとURLをコピーしました