Excel VBA 質問スレッド №2137 (未解決)

配列を決まった順番で並べたい

投稿者 : 文月投稿日時 : 2025/07/15(Tue) 15:30:17 OS : Windows 11 EXCEL : Excel 2019

在庫シートから、項目を抜き出して別シートを作成をするコードを作っています。

＜条件＞
・在庫シートはA～Z列×1000行ほどのデータがあります。
・この中から特定の項目を抜き出し、別ファイルを作成したいです。
・別シートに抜き出したい項目は５項目あり、必ず在庫シートの中に項目がありますが、列の並び順が変わる場合があります。

＜質問＞
以下のコードで、項目を抜き出すことはできたのですが、
元データの順番が変わると、結果の順番も変わってしまいます。

１．これを、固定の並び順で並ばせたい（結果シートの内容を、A：納品書、B：商品コード、…E：注文番号のように固定にしたい）
のですが、何かわかりやすくする方法はあるでしょうか？

２．追加で、数量が空白の場合は、行を詰めるという処理を入れたいのですが、一括で処理する方法はありますか？

ご教示いただけると幸いです。

With frWB.Worksheets("在庫")
For Each colName In Array("納品書№", "商品コード", "数量", "販売金額", "注文番号") '検索用項目をセット
colNo = Application.Match(colName, .Rows(1), 0)
If IsNumeric(colNo) Then
If srcCols Is Nothing Then
Set srcCols = .Columns(colNo)
Else
Set srcCols = Union(srcCols, .Columns(colNo)) '対象データの位置を配列として保存
End If
End If
Next
End With

[返信 1] Re : 配列を決まった順番で並べたい

投稿者 : ごんぼほり投稿日時 : 2025/07/15(Tue) 17:17:42

やりたいことが今ひとつ伝わってこないですが、
おそらくフィルタの詳細設定を利用するのが簡単だと思います。
VBAでは Range.AdvancedFilter メソッドです
調べてみてください。

[返信 2] Re : 配列を決まった順番で並べたい

投稿者 : てらてら投稿日時 : 2025/07/15(Tue) 19:33:49

こんにちは。
たぶんRangeに貯め込んでいるのだと思いますが、
項目の列を順番に並べたいなら１列づつコピーして貼り付けていった方が良いと思います。

空白行の削除は、色々なサンプルがあるので一例です。

参考にしてみてください。

Sub macro()
    Dim colName
    Dim srcCols As Range
    Dim colNo
    Dim i As Long
    
    'With frWB.Worksheets("在庫")
    With Worksheets("在庫")
    i = 1
    For Each colName In Array("納品書№", "商品コード", "数量", "販売金額", "注文番号") '検索用項目をセット
        colNo = Application.Match(colName, .Rows(1), 0)
        If IsNumeric(colNo) Then
            .Columns(colNo).Copy Worksheets("別シート").Cells(1, i)
        End If
        i = i + 1
    Next
    
    End With
    
    ' A列に値が無ければ行削除
    With Worksheets("別シート")
    For i = .Cells(.Rows.Count, "A").End(xlUp).Row To 1 Step -1
        If Application.WorksheetFunction.CountA(.Rows(i)) = 0 Then
            .Rows(i).Delete
        End If
    Next i
    End With
    
End Sub

[返信 3] Re : 配列を決まった順番で並べたい

投稿者 : ピロリ投稿日時 : 2025/07/16(Wed) 07:08:19

frWB（ブック変数）を使用しているってことは、在庫シートはこのマクロとは異なるブックに有るのですかね？
別シート（書き込み先）も別のブックなのでしょうか？
下のマクロでは、在庫シートのブックは frWB（シートは frSH ）、別シートのブックは toWB（シートは toSH ）としてます。
また、どちらのブックも便宜上 ThisWorkbook にしていますが、実態に合わせて見直して下さい。

＞数量が空白の場合は、行を詰める・・・
とのことなので、数量（C列）が空白セルの場合に、その行を削除するんですよね。
最終行から 2行目までループし、空白判定と行削除をする訳ですが、A～E列のどの列が一番下なのでしょう？
要は、必ず入力される項目はどの列かってこと。　A列ならば、toSH.Cells(toSH.Rows.Count, "A").End(xlUp).Row が最終行。
下のマクロでは、とりあえず UsedRange の一番下を最終行としていますが、不都合あれば↑のように修正して下さい。

上の２点以外は、[返信 2] てらてらさんの考え方と一緒です。　ご参考まで･･･

Sub Sample()
    Dim frWB As Workbook, frSH As Worksheet
    Set frWB = ThisWorkbook                 '← コピー元ブックは 本ブックとしてます　 ⇒ 見直して下さい
    Set frSH = frWB.Worksheets("在庫")
    Dim toWB As Workbook, toSH As Worksheet
    Set toWB = ThisWorkbook                 '← コピー先ブックも 本ブックとしてます　 ⇒ 見直して下さい
    Set toSH = toWB.Worksheets("別シート")  '← コピー先シートは ｢別シート｣としてます ⇒ 見直して下さい
    Dim MyArr As Variant
    MyArr = Array("納品書№", "商品コード", "数量", "販売金額", "注文番号")     '項目名とコピペする順番
    Dim i As Long, colNo As Variant
    For i = 0 To UBound(MyArr)
        colNo = Application.Match(MyArr(i), frSH.Rows(1), 0)                    '項目名を検索して、
        If IsNumeric(colNo) Then frSH.Columns(colNo).Copy toSH.Cells(1, i + 1)  '見付かったら列をコピペ
    Next i
   'For i = toSH.Cells(toSH.Rows.Count, "A").End(xlUp).Row To 2 Step -1         '最終行～2行目のループ
    For i = toSH.UsedRange.Rows(toSH.UsedRange.Rows.Count).Row To 2 Step -1     '最終行～2行目のループ
        If toSH.Cells(i, "C") = "" Then toSH.Rows(i).Delete                     '｢数量｣が空白なら行削除
    Next i
End Sub

[返信 4] Re : 配列を決まった順番で並べたい

投稿者 : 文月投稿日時 : 2025/07/16(Wed) 13:39:46

条件の説明が分かりづらくてすみません。

在庫シートのある参照元ファイルと、抽出されたデータを出力するファイルと、マクロファイルは、それぞれ別のファイルになります。
マクロをコマンドから実行させるイメージになります。

このあと後続の処理が続くため、処理速度を上げたくて配列で検索する方法を取りました。

抽出する条件が、現在５項目なのですが、今後増えたり項目順が変わる可能性もあり
毎回同じ順番で簡単にソート出来る方法がないかなと探しております。

空白行の削除については、現在いったん抽出貼付けしてから行っているため、抽出ついでに出来たら楽なのかなと思っています。

条件に合う項目を検索→ヒットしたものを指定場所にセット
　→ある項目が空白なら、検索結果をセットせずにスキップし次の行へ
×データ数分ループ

イメージとしては、このような感じなのですが、結局配列よりもループで処理した方が早いんでしょうか…。

[返信 5] Re : 配列を決まった順番で並べたい

投稿者 : 匿名投稿日時 : 2025/07/16(Wed) 14:03:10

【Sheet1】
納品書No Dummy1 商品コード数量 Dummy2 販売金額 Dummy3 Dummy4 注文番号
51 83 80 49 82 14 89 37 97
15 58 81 64 12 24 75 96
75 79 66 51 82 78 96 43 44
7 26 27 84 11 8 43 17

【Sheet2】
注文番号商品コード Dummy1 数量販売金額 Dummy2 納品書No
132 116 134 131 112 109 123
174 175 154 151 167 194
111 190 176 117 179 117
116 175 112 162 195 172 150

【Sheet3】出力用
納品書No 商品コード数量販売金額注文番号
51 80 49 14 97
75 66 51 78 44
123 116 131 112 132
150 175 162 195 116

【質問内容の確認】
Sheet1とSheet2の項目の順番が違う
Sheet3は項目の順番が固定

Sheet1でもSheet2の項目の順番であっても
Sheet3の項目の同じ項目の所に
Sheet1又はSheet2の値を代入する

-----------------------------------
上記のSheet3の結果は、
Test1を実行後にText2を実行したものです。
-----------------------------------

Sub Test1()
    '元データシート
    Call Sample("Sheet1")
End Sub

Sub Test2()
    '別の元データシート※Test1のシートとは項目の順序が違う
    Call Sample("Sheet2")
End Sub

Sub Sample(strSheetName As String)
    Dim wb As Workbook
    Dim wsInput As Worksheet
    Dim wsOutput As Worksheet
    Dim lngInpLastCol As Long
    Dim lngInpLastRow As Long
    Dim lngOutLastRow As Long
    Dim lngCol As Long
    Dim lngRow As Long
    Dim strItem As String
    Dim i As Long
    
    Set wb = ThisWorkbook
    Set wsInput = wb.Worksheets(strSheetName) '元データシート
    Set wsOutput = wb.Worksheets("Sheet3") '出力用シート
    
    lngInpLastCol = wsInput.Range("A1").CurrentRegion.Columns.Count '元データ用の最終列取得
    lngInpLastRow = wsInput.Range("A1").CurrentRegion.Rows.Count    '元データ用の最終行取得
    lngOutLastRow = wsOutput.Range("A1").CurrentRegion.Rows.Count   '出漁用データの最終行取得
    
    For i = 1 To lngInpLastCol
        strItem = wsInput.Cells(1, i).Value '元データシートの項目名を保持
        lngCol = FindOutputItemCol(wsOutput, strItem) '出力用データシートの該当項目の列番号取得
        If Not lngCol = 0 Then
            '元データシートの該当列の値を、出力用シートに代入
            wsOutput.Range(wsOutput.Cells(lngOutLastRow + 1, lngCol), wsOutput.Cells(lngOutLastRow + lngInpLastRow - 1, lngCol)).Value = _
                wsInput.Range(wsInput.Cells(2, i), wsInput.Cells(lngInpLastRow, i)).Value
        End If
    Next i
    
    '数量が空欄(長さ0の文字列)の行を削除
    For i = (lngOutLastRow + lngInpLastRow - 1) To 2 Step -1
        If Trim(wsOutput.Cells(i, "C").Value & "") = "" Then wsOutput.Rows(i).Delete
    Next i
    
    Set wsOutput = Nothing
    Set wsInput = Nothing
    Set wb = Nothing
    
End Sub

'===　元データシートの項目と出力用シートの項目が一致する列番号を取得　===
'
'---　引数　---
'ws      ：出力用ワークシートオブジェクト
'strItenm：元データシートの項目名
'
'---　戻り値　---
'元データシートの項目名と出力用シートの項目が一致する出力用シートの列番号
'
'========================================================================
Function FindOutputItemCol(ws As Worksheet, strItem As String) As Long
    Dim rng As Range
    Dim rngFind As Range
    
    FindOutputItemCol = 0 '戻り値の初期化
    
    '出力用シートの検索範囲
    Set rng = ws.Range(ws.Cells(1, "A"), ws.Cells(1, "E"))
    
    '元データの項目名を出力用シートの検索範囲から検索
    Set rngFind = rng.Find(What:=strItem, LookIn:=xlValues, LookAt:=xlWhole)
    
    '検索して見つかった場合、その列の列番号を取得
    If Not rngFind Is Nothing Then FindOutputItemCol = rngFind.Column
    
    Set rngFind = Nothing
    Set rng = Nothing
    
End Function

[返信 6] Re : 配列を決まった順番で並べたい

投稿者 : 匿名投稿日時 : 2025/07/16(Wed) 14:03:41

Sub Test1()
    '元データシート
    Call Sample("Sheet1")
End Sub

Sub Test2()
    '別の元データシート※Test1のシートとは項目の順序が違う
    Call Sample("Sheet2")
End Sub

Sub Sample(strSheetName As String)
    Dim wb As Workbook
    Dim wsInput As Worksheet
    Dim wsOutput As Worksheet
    Dim lngInpLastCol As Long
    Dim lngInpLastRow As Long
    Dim lngOutLastRow As Long
    Dim lngCol As Long
    Dim lngRow As Long
    Dim strItem As String
    Dim i As Long
    
    Set wb = ThisWorkbook
    Set wsInput = wb.Worksheets(strSheetName) '元データシート
    Set wsOutput = wb.Worksheets("Sheet3") '出力用シート
    
    lngInpLastCol = wsInput.Range("A1").CurrentRegion.Columns.Count '元データ用の最終列取得
    lngInpLastRow = wsInput.Range("A1").CurrentRegion.Rows.Count    '元データ用の最終行取得
    lngOutLastRow = wsOutput.Range("A1").CurrentRegion.Rows.Count   '出漁用データの最終行取得
    
    For i = 1 To lngInpLastCol
        strItem = wsInput.Cells(1, i).Value '元データシートの項目名を保持
        lngCol = FindOutputItemCol(wsOutput, strItem) '出力用データシートの該当項目の列番号取得
        If Not lngCol = 0 Then
            '元データシートの該当列の値を、出力用シートに代入
            wsOutput.Range(wsOutput.Cells(lngOutLastRow + 1, lngCol), wsOutput.Cells(lngOutLastRow + lngInpLastRow - 1, lngCol)).Value = _
                wsInput.Range(wsInput.Cells(2, i), wsInput.Cells(lngInpLastRow, i)).Value
        End If
    Next i
    
    '数量が空欄(長さ0の文字列)の行を削除
    For i = (lngOutLastRow + lngInpLastRow - 1) To 2 Step -1
        If Trim(wsOutput.Cells(i, "C").Value & "") = "" Then wsOutput.Rows(i).Delete
    Next i
    
    Set wsOutput = Nothing
    Set wsInput = Nothing
    Set wb = Nothing
    
End Sub

'===　元データシートの項目と出力用シートの項目が一致する列番号を取得　===
'
'---　引数　---
'ws      ：出力用ワークシートオブジェクト
'strItenm：元データシートの項目名
'
'---　戻り値　---
'元データシートの項目名と出力用シートの項目が一致する出力用シートの列番号
'
'========================================================================
Function FindOutputItemCol(ws As Worksheet, strItem As String) As Long
    Dim rng As Range
    Dim rngFind As Range
    
    FindOutputItemCol = 0 '戻り値の初期化
    
    '出力用シートの検索範囲
    Set rng = ws.Range(ws.Cells(1, "A"), ws.Cells(1, "E"))
    
    '元データの項目名を出力用シートの検索範囲から検索
    Set rngFind = rng.Find(What:=strItem, LookIn:=xlValues, LookAt:=xlWhole)
    
    '検索して見つかった場合、その列の列番号を取得
    If Not rngFind Is Nothing Then FindOutputItemCol = rngFind.Column
    
    Set rngFind = Nothing
    Set rng = Nothing
    
End Function

[返信 7] Re : 配列を決まった順番で並べたい

投稿者 : 匿名投稿日時 : 2025/07/16(Wed) 14:04:40

↑すみません。
2回投稿してしまいました。

[返信 8] Re : 配列を決まった順番で並べたい

投稿者 : ピロリ投稿日時 : 2025/07/16(Wed) 15:06:00

■[返信 4] 文月さん（2025-07-16 13:39:46）の記事
＞このあと後続の処理が続くため、処理速度を上げたくて配列で検索する方法を取りました。
ループでの行削除って動作確認しました？　たかだか 1000行程度のループ＆行削除で、どんだけ遅くなるの？って気もしますが、

＞空白行の削除については、現在いったん抽出貼付けしてから行っているため、抽出ついでに出来たら楽なのかなと思っています。
なら、[返信 1] ごんぼほりさんの Range.AdvancedFilterメソッドを試してみてはいかがですか？　速いし、楽そうだし･･･

当掲示板について

Excel VBA に関する掲示板です。Excel VBA に関する質問や疑問、それに対する解決方法など気軽に投稿してください。
記事内ではHTMLのタグは使用できません。
記事は一度投稿すると修正できません。内容を訂正したい場合は返信で対応してください。
Sub〜End Sub、Function〜End Function は自動的にプログラムコードとみなし、枠で囲って見やすくします。
Excel VBA とは関係ないことや、他人が不快に思うようなことなど、管理人が適当でないと判断した記事は削除する場合があります。

返信入力フォーム

( 処理日時 : 2025-07-20 02:36:04 )