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

130:マクロ素材

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

結論

Sub 下のセルとさらにその下のセルを合体してコピー()
'
' 下のセルとさらにその下のセルを合体してコピー Macro
' 下のセルとさらにその下のセルを＆で合体してコピー
' 列の最も右のセルまでコピーして値固定して、１行目２行目を削除
' 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
   '１行目と２行目を削除する。
    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
この記事では、整数をアルファベット文字に変換する方法について説明します。
learn.microsoft.com

説明

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

初めに

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

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

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

Selection.Copy

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

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

‘現在の列を調べる

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

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

　’MsgBox 現在のセル列

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

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

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

確認のために、ＭＳＧＢＯＸで、確認した形跡が残っております。

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

‘最後の列を調べる

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　’私の場合には３行目に合体したフィールド名を入れるので３

Range(コピー位置).Select

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

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

Application.CutCopyMode = False

不要な１行目と２行目を削除する。

‘１行目と２行目を削除する。

Rows(“1:2”).Select

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

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

最後にA1に戻って終了

Range(“A1”).Select

という内容でした。

コメント

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