「並び替えとフィルター」を使って空白以外を抽出

質問

シート１に別のシートから抽出した人名が並んでいます。
シート２にも別のシートから抽出した数字が並んでいます。
人名と数字は同じ行／列に格納されます。
シート１もシート２も空白が含まれています。
シート３に人名と数値を隣り合わせで格納したいのです。

シート１とシート２共に、「並び替えとフィルター」を使って空白以外を
抽出したいのですが、「昇順／降順」を使うと、人名と数字の関連が崩れる
ので困っています。
「並び替えとフィルター」で不可能ならば、別な方法でも構いません。
ご教示いただけますようお願い致します。

シート１　　　　　　　　　　　　　　　　　シート２
　　Ａ　　　Ｂ　　　Ｃ　　　Ｄ　　　 　　　　　Ａ　　　Ｂ　　　Ｃ　　　Ｄ
１　太郎　　　　　次郎　　　　　　　　　１　100　　　　　 　10
２　三郎　花子　　　　　春子　　　　　２　 　5　　200　　　　　　 50
３　　　　　　　　　秋子　夏子　　　　　３　　　　　　　　　500　　100
４　四郎　五郎　六郎　　　　　　　　　４　 80　　300　 400
５　七郎　　　　　　　　　冬子　　　　　５　300　　　 　　　　　　　 60

シート３
　　Ａ　　　Ｂ　　　Ｃ　　　Ｄ　　　E　　　F　　　G　　　H
１　太郎　100　　花子　200　　次郎　10　　春子　50
２　三郎　 　5　　五郎　300　　秋子　500　 夏子１00　　　　　
３　四郎　 80　　　　　　　　　　六郎　400　 冬子 400　　　
４　七郎　300 　　　　
５

回答No.9

MackyNo1 · ベストアンサー

No8の回答の補足です。

質問の流れを見ると、元データがすべて数式で表示されているのでしょうか。
この場合は、NO8の回答では数式セルがすべて選択されてしまう可能性が高いので、空白に見えるセルだけ選択するには、以下のような手順でデータ処理する必要があります。

すなわち、元データを選択して右クリック「コピー」、シート3で右クリック「形式を選択して貼り付け」で「値」で貼り付けて数式をすべて値に変更しておきます。
このようにすると空白に見えるセルには空白文字列が入力されていますので（実際の空白セルではないので）、以下のような手順で空白文字列セルをすべて選択して、No8の回答の手順で空白文字列セルを一括削除することができます。

すなわち、１つの空白文字列セルを選択して、右クリックコピー、Ctrl+Fで検索ダイアログを出して、そのまま検索する文字列の欄にCtrl+Vで空白文字列を貼り付けてから「すべて検索」してCtrl+Aで該当セルをすべて選択して右クリックから「削除」してください。

お礼

度々のご助言本当にありがとうございます。
No.7を実行しましたが、まだ、ダメそうです。
No.9方式の方向で検討させていただきます。
「値」で貼り付けて数式をすべて値に変更することができましたので、これで大丈夫そうです。
今夜も仕事なのでこれから仮眠をとります。
結果は別途報告させていただきます。

補足

何度もご指導いただき本当にありがとうございました。
お蔭でこの方法で目的を達成することができました。
重ねてお礼を申し上げますと共に深いご見識に敬意を表します。

回答No.8

MackyNo1

>『データ範囲を選択し、Ctrl+Gでジャンプダイアログを出して、「セル選択」「空白セル」で「OK」し、そのまま右クリックから「削除」から「上方向にシフト」を選択します。』
これが知りたかったポイントです。

本当の空白セルではなく、数式の「""」の空白表示のセルを削除したいなら以下のような手順で簡単に見掛けの空白セルを削除できます。

データ範囲を選択して、Ctrl+Fのショートカット操作で検索ダイアログを出して、検索する文字列に「""」を入力して「すべて検索」し、その後Ctrl+Aのショートカット操作で、空白に見えるセルをすべて選択し、右クリックから「削除」で「上方向にシフト」してください。

もし、上記の回答でうまくいかない場合は、データの詳細を補足説明してください。

回答No.7

tom04

何度もごめんなさい。

前回のコードで一部不備がありました。

If Worksheets.Count < 4 Then
Worksheets.Add after:=wS3
Set wS4 = Worksheets(4)
End If

の4行を

If Worksheets.Count < 4 Then
Worksheets.Add after:=wS3
End If
Set wS4 = Worksheets(4)

に訂正してください。
Sheet見出しに4個以上のSheetが存在した場合は前回のコードではうまく動きません。

これが最後になれば良いのですが・・・m（_ _）m

お礼

本当にありがとうございます。
これから仕事なので、明日帰ってから検証させていただきます。

回答No.6

tom04

何度もお邪魔します。

＞実行に３０分以上かかってしまいました。

というコトはかなりのデータ量だと思いますので、いままでのように各セルを舐めるように検索していたのでは
話にならないと思います。
別の方法にしてみました。

尚、Sheet4を作業用のSheetとして使用していますが、Sheet見出し上に3Sheet分だけ表示されていれば
マクロが動くようにしています。
いままでのコードはすべて無視して↓のコードにしてマクロを実行してみてください。
（今回も標準モジュールです）

Sub Sample4()
Dim j As Long, endRow As Long, endCol As Long
Dim wS1 As Worksheet, wS2 As Worksheet, wS3 As Worksheet, wS4 As Worksheet
Set wS1 = Worksheets("Sheet1")
Set wS2 = Worksheets("Sheet2")
Set wS3 = Worksheets("Sheet3")
Application.ScreenUpdating = False
On Error Resume Next
wS3.Cells.Clear
If Worksheets.Count < 4 Then
Worksheets.Add after:=wS3
Set wS4 = Worksheets(4)
End If
endRow = wS1.UsedRange.Rows.Count
endCol = wS1.UsedRange.Columns.Count
For j = 1 To endCol
Range(wS1.Cells(1, j), wS1.Cells(endRow, j)).Copy wS3.Cells(1, j * 2 - 1)
Next j
endRow = wS2.UsedRange.Rows.Count
endCol = wS2.UsedRange.Columns.Count
For j = 1 To endCol
Range(wS2.Cells(1, j), wS2.Cells(endRow, j)).Copy wS3.Cells(1, j * 2)
Next j
endRow = wS3.UsedRange.Rows.Count
endCol = wS3.UsedRange.Columns.Count
With Range(wS3.Cells(1, 1), wS3.Cells(endRow, endCol))
.Value = .Value
End With
endRow = wS3.UsedRange.Rows.Count
endCol = wS3.UsedRange.Columns.Count
For j = 1 To endCol
Range(wS3.Cells(1, j), wS3.Cells(endRow, j)).Cut wS4.Cells(1, 1)
With Range(wS4.Cells(1, "B"), wS4.Cells(endRow, "B"))
.Formula = "=IF(A1="""",2,1)"
.Value = .Value
End With
wS4.Range("A1").CurrentRegion.Sort key1:=wS4.Range("B1"), order1:=xlAscending, Header:=xlNo
wS4.Range("A:A").Copy wS3.Cells(1, j)
wS4.Range("A:B").Clear
Next j
Application.DisplayAlerts = False
Worksheets(4).Delete
Application.DisplayAlerts = True
Application.ScreenUpdating = True
MsgBox "処理完了"
End Sub

こんどはどうでしょうか？m（_ _）m

回答No.5

tom04

たびたびお邪魔します。

結局最初の方法でよいと思うのですが、
もしかして空白セルは数式が入っていて空白に見えている！
というコトはないでしょうか？

もしそうであれば数式が入っていて空白に表示されているセルはそのまま残ってしまいますので、
別案として・・・

Sub Sample3()
Dim i As Long, j As Long, endRow As Long, endCol As Long, wS1 As Worksheet, wS2 As Worksheet
Set wS1 = Worksheets("Sheet1")
Set wS2 = Worksheets("Sheet2")
Application.ScreenUpdating = False
Application.ScreenUpdating = False
With Worksheets("Sheet3")
.Cells.Clear
For j = 1 To wS1.UsedRange.Columns.Count
wS1.Columns(j).Copy .Cells(1, j * 2 - 1)
Next j
For j = 1 To wS2.UsedRange.Columns.Count
wS2.Columns(j).Copy .Cells(1, j * 2)
Next j
endRow = .UsedRange.Rows.Count
endCol = .UsedRange.Columns.Count
For i = endRow To 1 Step -1
For j = 1 To endCol
If .Cells(i, j) = "" Then
.Cells(i, j).Delete shift:=xlUp
End If
Next j
Next i
End With
Application.ScreenUpdating = True
End Sub

今度はうまく動けばよいのですが・・・m(_ _)m

お礼

私の説明不足で何度もお手数をお掛けしました。
ご指摘通り「空白セルは数式が入っていて空白に見えている！」です。
ご提示いただいたマクロで目的の形を実現することができました。
本当にありがとうございました。
但し、Excelの容量が大きいことやＣＰＵパワーが低いこともあり、実行に３０分以上かかってしまいました。
残念ながら、これでは実際には使えないので、シート１とシート２をそれぞれ、単純に上詰めすることができればあとは何とかできます。
度々で大変恐縮ですが、お知恵を拝借できますよう重ねてお願い申し上げます。
補足：これまではシート１のみであり、「並び替え」を使ってソート（マクロ記録）していたのですが、シート２と連動させる必要がでてきて、シート２は数字なので、降順／昇順を使うとうまく、シート１と連動しないので困っています。
シート１とシート２の見かけ上の空白セルを取り除いて上詰めできれば解決します。

回答No.4

tom04

No.3です。

＞各列毎に空白行を取り除いて、頭詰めすることはできるでしょうか？
すなわち列も空白は削除して左詰めしたい！というコトでしょうかね？

もしそうであれば↓のコードに変更してみてください。
※　1行だけの追加ですが、どの行に！というよりもう一度最初からのコードを載せますので
前回のコードはすべて削除して新たにコピー＆ペーストしてみてください。

Sub Sample2() 'この行から
Dim j As Long, endRow As Long, endCol As Long, wS1 As Worksheet, wS2 As Worksheet
Set wS1 = Worksheets("Sheet1")
Set wS2 = Worksheets("Sheet2")
Application.ScreenUpdating = False
With Worksheets("Sheet3")
.Cells.Clear
For j = 1 To wS1.UsedRange.Columns.Count
wS1.Columns(j).Copy .Cells(1, j * 2 - 1)
Next j
For j = 1 To wS2.UsedRange.Columns.Count
wS2.Columns(j).Copy .Cells(1, j * 2)
Next j
endRow = .UsedRange.Rows.Count
endCol = .UsedRange.Columns.Count
On Error Resume Next '←お・ま・じ・な・い！
Range(.Cells(1, 1), .Cells(endRow, endCol)).SpecialCells(xlCellTypeBlanks).Delete shift:=xlUp
.Range("A1").CurrentRegion.SpecialCells(xlCellTypeBlanks).Delete shift:=xlToLeft '←この行を追加
End With
Application.ScreenUpdating = True
End Sub 'この行まで

今度はどうでしょうか？m(_ _)m

お礼

すみません。
左詰めではなく、上詰めです。
よろしくお願い致します。

回答No.3

tom04

こんばんは！
VBAになってしまいますが、一例です。

Sheet1とSheet2のデータは行・列とも一致しているという前提です。
（例）「太郎」がSheet1のA1にあれば、それに対応するデータがSheet2の同じセル番地に存在する

Alt＋F11キー　→　メニュー　→　挿入　→　標準モジュール　→　VBE画面に
↓のコードをコピー＆ペーストしてマクロを実行してみてください。
（Alt＋F8キー　→　マクロ　→　マクロ実行です）

Sub Sample1() 'この行から
Dim j As Long, endRow As Long, endCol As Long, wS1 As Worksheet, wS2 As Worksheet
Set wS1 = Worksheets("Sheet1")
Set wS2 = Worksheets("Sheet2")
Application.ScreenUpdating = False
With Worksheets("Sheet3")
.Cells.Clear
For j = 1 To wS1.UsedRange.Columns.Count
wS1.Columns(j).Copy .Cells(1, j * 2 - 1)
Next j
For j = 1 To wS2.UsedRange.Columns.Count
wS2.Columns(j).Copy .Cells(1, j * 2)
Next j
endRow = .UsedRange.Rows.Count
endCol = .UsedRange.Columns.Count
On Error Resume Next '←お・ま・じ・な・い！
Range(.Cells(1, 1), .Cells(endRow, endCol)).SpecialCells(xlCellTypeBlanks).Delete shift:=xlUp
End With
Application.ScreenUpdating = True
End Sub 'この行まで

こんな感じではどうでしょうか？m(_ _)m

お礼

高度なご回答をいただき、感激しています。
早速、実行してみましたところ、Sheet1とSheet2の内容が綺麗に並びました。
しかし、行は元のままでした。
各列毎に空白行を取り除いて、頭詰めすることはできるでしょうか？
申し訳ございませんが、もう少しお知恵を拝借できると大変助かります。

回答No.2

noname#192382

ブランクのマクロを作り、それにしたのマクロをコピーはり付けした後、このマクロを実行させるとシート3の各セルに、対応するシート1とシート2のデータをつないだデータが入っています。

Sub Macro1()
'
' Macro1 Macro
' マクロ記録日 : 2013/11/6 ユーザー名 :
'
Dim i As Integer, j As Integer
'
For i = 1 To 2
For j = 1 To 4
Worksheets(3).Cells(i, j) = Worksheets(1).Cells(i, j) & Worksheets(2).Cells(i, j)
Next
Next
End Sub

お礼

お礼が遅くなりました。
ありがとうございました。
検証させていただきます。

回答No.1

MackyNo1

ご希望の操作は以下のような手順で行うことができます。

まずシート1とシート２のシート名部分をCtrｌキーを押しながらクリックして作業グループにして、B列を選択して、右クリック「挿入」、同様にD列をクリックして右クリック「挿入」の操作を繰り返し、１列ごとに空白列の空いたリストを作成します。
次にデータ範囲を選択し、Ctrl+Gでジャンプダイアログを出して、「セル選択」「空白セル」で「OK」し、そのまま右クリックから「削除」から「上方向にシフト」を選択します。

最後にシート名を右クリックして「作業グループの解除」を行い、シート2のデータ範囲を選択し、右クリック「コピー」から、シート1のB1セル（数字データを入力する１つ右のセル）を選択し、右クリック「形式を選択して貼り付け」で「空白セルを無視する」にチェックを入れて「すべて」を貼り付けてください。

ちなみにシート１とシート2のデータを残したい場合は、シート3上にデータをコピーして同様な作業をすることになります（このケースでは列を挿入するのではなく、Shiftドラッグにより、そのままデータ列を挿入する方が簡単です）。

お礼

ご回答いただきありがとございました。
『データ範囲を選択し、Ctrl+Gでジャンプダイアログを出して、「セル選択」「空白セル」で「OK」し、そのまま右クリックから「削除」から「上方向にシフト」を選択します。』
これが知りたかったポイントです。
大変参考になりました。
ありがとうございました。