質問をすることでしか得られない、回答やアドバイスがある。

15分調べてもわからないことは、質問しよう!

新規登録して質問してみよう
ただいま回答率
85.50%
VBA

VBAはオブジェクト指向プログラミング言語のひとつで、マクロを作成によりExcelなどのOffice業務を自動化することができます。

マクロ

定義された処理手続きに応じて、どのような一連の処理を行うのかを特定させるルールをマクロと呼びます。

配列

配列は、各データの要素(値または変数)が連続的に並べられたデータ構造です。各配列は添え字(INDEX)で識別されています。

Q&A

1回答

3079閲覧

表の範囲内で列を入れ替えるマクロを作成したいです

STELLIE

総合スコア0

VBA

VBAはオブジェクト指向プログラミング言語のひとつで、マクロを作成によりExcelなどのOffice業務を自動化することができます。

マクロ

定義された処理手続きに応じて、どのような一連の処理を行うのかを特定させるルールをマクロと呼びます。

配列

配列は、各データの要素(値または変数)が連続的に並べられたデータ構造です。各配列は添え字(INDEX)で識別されています。

0グッド

0クリップ

投稿2020/05/13 09:34

前提・実現したいこと

P16:Q17とS16:Q17のリストで列を入れ替えたい名前を選択し、移動のボタンを押すと、対象のB列からN列までを入れ替えるようなマクロを作成したいと考えています。
素人考えですが、P16:Q17のリストで選択した名前をC列から検索し、AI〜AUへコピー、S16:Q17のリストで選択したセルへAI〜AUにコピーした値をそれぞれ値貼り付けしたいと考えています。

発生している問題・エラーメッセージ

名前を検索するところまではできるのですが、名前のあった列のB列、N列を指定する方法がわかりません。。。

該当のソースコード

VBA

ソースコード
'MessegeBox
Dim rc As VbMsgBoxResult
rc = MsgBox("入れ替えてもよろしいですか?", vbYesNo + vbQuestion)

If rc = vbYes Then MsgBox "処理中です", vbInformation Else MsgBox "処理を中止します", vbCritical End If

'処理軽減
Application.ScreenUpdating = False

'移動する患者をセレクト_1
'移動する患者1のセレクト/検索→Range指定がされていない
Cells.Find(What:="P16:Q17", After:=ActiveCell, LookIn:=xlFormulas, LookAt _
:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
False, MatchByte:=False, SearchFormat:=False).Activate
Cells.FindNext(After:=ActiveCell).Activate

試したこと

表以外の項目を全て表の下に移動し、列入れ替えにしようとも思いましたが、まず検索した名前のある列を指定できるようにならなければならず同じところで行き詰まりました。

ここに問題に対して試したことを記載してください。

補足情報(FW/ツールの!)イメージ説明バージョンなど)

ここにより詳細な情報を記載してください。

気になる質問をクリップする

クリップした質問は、後からいつでもMYページで確認できます。

またクリップした質問に回答があった際、通知やメールを受け取ることができます。

バッドをするには、ログインかつ

こちらの条件を満たす必要があります。

guest

回答1

0

上下行値入れ替えのサンプルありましたので差し上げます。
適当なシートへ張り付けて動かしてみて下さい。
使い方は、まずシートへ値を適当に入力します。
その後に、その値を選択します。セル選択した状態で、
Function:[セル選択範囲の上下を入れ替える]を動かします。
すると上下の値が入れ替わる筈です。

こちら動作確認できましたら、[対象の上行下行の位置を取得する]を
頑張ってご自分で修正作成してみて下さい。
対象のセル番号を取得して、[上下両端入替え処理]へ渡してcallすれば動く筈です。
尚、[セル選択範囲の上下を入れ替える]部分はExcel2010にて確認済みです。

Option Explicit Function 対象の上行下行の位置を取得する() Dim MyRange As Range Dim lRow1 As Long Dim lCol1 As Long Dim lRow2 As Long Dim lCol2 As Long '上行取得・列固定(P16に選択した値/C7:C1000は選択されるべきリスト範囲) For Each MyRange In Range("C7:C1000") If MyRange.Text = Range("P16").Text Then lRow1 = MyRange.Row lCol1 = 13 Exit For End If Next '下行取得・列固定(S16に選択した値/C7:C1000は選択されるべきリスト範囲) For Each MyRange In Range("C7:C1000") If MyRange.Text = Range("S16").Text Then lRow1 = MyRange.Row lCol1 = 13 Exit For End If Next '実行 Call 上下両端入替え処理(lRow1, lCol1, lRow2, lCol2) End Function Function セル選択範囲の上下を入れ替える() Dim lRow1 As Long Dim lCol1 As Long Dim lRow2 As Long Dim lCol2 As Long lRow1 = Selection.Row lCol1 = Selection.Column lRow2 = lRow1 + Selection.Rows.Count - 1 lCol2 = lCol1 + Selection.Columns.Count - 1 Call 上下両端入替え処理(lRow1, lCol1, lRow2, lCol2) End Function '------------------------------ ' Test_Sample_Miniature '------------------------------ Function 上下両端入替え処理( _ ByVal mlRow1 As Long, _ ByVal mlCol1 As Long, _ ByVal mlRow2 As Long, _ ByVal mlCol2 As Long _ ) Dim blnFLG As Boolean Dim MyObj As Range Dim MyObjWork As Range Dim MyArray() As Variant Dim MyNFLArray() As Variant Dim iX As Integer Dim lRow As Integer Dim lCol As Integer 上下両端入替え処理 = False For Each MyObj In Range(Cells(mlRow1, mlCol1), Cells(mlRow1, mlCol2)) ' iX = 0 lCol = MyObj.Column For Each MyObjWork In Range(Cells(mlRow1, lCol), Cells(mlRow2, lCol)) iX = iX + 1 ReDim Preserve MyArray(iX - 1) ReDim Preserve MyNFLArray(iX - 1) MyArray(iX - 1) = MyObjWork.Formula MyNFLArray(iX - 1) = MyObjWork.NumberFormatLocal Next ' iX = 0 For Each MyObjWork In Range(Cells(mlRow1, lCol), Cells(mlRow2, lCol)) ' '両端のみ処理する。 If MyObjWork.Row = mlRow1 Or MyObjWork.Row = mlRow2 Then ' blnFLG = True ' If (Left(MyArray(UBound(MyArray) - iX), 1) = "=") Then blnFLG = False End If If (Left(MyObjWork.Formula, 1) = "=") Then blnFLG = False End If If blnFLG = True Then MyObjWork.Formula = MyArray(UBound(MyArray) - iX) MyObjWork.NumberFormatLocal = MyNFLArray(UBound(MyNFLArray) - iX) End If ' End If iX = iX + 1 ' Next ' Next 上下両端入替え処理 = True Exit Function '** Err_処理: MsgBox "Error " & " ( " & Err.Number & " " & Err.Description & " )" '** End Function

修正作成時の質問にはお答え出来ないかと思いますが頑張って下さい。

投稿2020/05/14 03:05

編集2020/05/21 23:53
tosi

総合スコア553

バッドをするには、ログインかつ

こちらの条件を満たす必要があります。

あなたの回答

tips

太字

斜体

打ち消し線

見出し

引用テキストの挿入

コードの挿入

リンクの挿入

リストの挿入

番号リストの挿入

表の挿入

水平線の挿入

プレビュー

まだベストアンサーが選ばれていません

会員登録して回答してみよう

アカウントをお持ちの方は

15分調べてもわからないことは
teratailで質問しよう!

ただいまの回答率
85.50%

質問をまとめることで
思考を整理して素早く解決

テンプレート機能で
簡単に質問をまとめる

質問する

関連した質問