Excel 任意の列の特定の行のみ値の取得

質問

書籍とサイトで教えていただいた説明などを見ながら、ExcelのVBAでセル内のデータの操作について勉強中ですが、タイトルのようなことをやる場合のオブジェクト式の選び方がわかりません。
よろしくお願いします。

例えば図のようなデータが入った"Sheet1"があり、行数、列数は様々なのですが、やりたいことは

・A列にエラーコード（ここでは"9999"または特定文字列）、空行、0が入っている行（ピンク色がついたセルのある行）は無視する。
・任意の列がコピー元（ここでは「A列＝コード」「B列＝商品名」「E列＝価格」で、上記に該当しないセルが対象
・そのセルの値のみ取得し、"Sheet2"のA～C列に上から順に（上詰めで）「値」のみをはりつけたい

Dim i As Long

Worksheets("Sheet1").Select
Rows(1).Copy Worksheets("Sheet2").Range("A1")

For i = 2 To Range("A65536").End(xlUp).Row
If Cells(i, "A") = 9999 And IsNumeric(Range("A" & i)) Then

この記述ではこのデータ操作ではエラーを変えすのですが、
根本的な「任意の列の特定の行のみの値の取得（と他シートへの複写）」の概念がわかっていません。

正しく動作する記述において、なぜそのオブジェクト式を採用するのかも含めて教えていただければと思います。

よろしくお願いします。

回答No.3

kagakusuki · ベストアンサー

1行ごとに処理するのではなく、まとめて一気にコピーするやり方の一例その1

Sub QNo8985905_Excel_任意の列の特定の行のみ値の取得()

Dim CopySheet As Worksheet, PasteSheet As Worksheet, _
CopySheetName As String, PasteSheetName As String, _
KeyColumn As String, LeftColumn As String, RightColumn As String, _
DeleteColumn As String, FirstRow As Long, LastRow As Long, _
myRange As Range

CopySheetName = "Sheet1" ' コピー元のシートのシート名
PasteSheetName = "Sheet2" ' 貼り付け先のシートのシート名
FirstRow = 1 ' コピー元のシートにおいて項目欄として使用されている行
LeftColumn = "A" ' 元データが入力されている左端の列
RightColumn = "E" ' 元データが入力されている右端の列
KeyColumn = "A" ' エラーコードが入力されている列
DeleteColumn = "C:D" ' 貼り付けない列範囲

If IsError(Evaluate("ROW('" & CopySheetName & "'!A1)")) Then
MsgBox "元データのシートとして登録されている" & vbCrLf _
& vbCrLf & CopySheetName & vbCrLf & vbCrLf & _
"というシート名のシートが見つかりません。" & vbCrLf & _
"マクロを終了します。", vbExclamation, "無効なシート名"
Exit Sub
Else
Set CopySheet = Sheets(CopySheetName)
End If
If IsError(Evaluate("ROW('" & PasteSheetName & "'!A1)")) Then
MsgBox "貼り付け先のシートとして登録されている" & vbCrLf _
& vbCrLf & PasteSheetName & vbCrLf & vbCrLf & _
"というシート名のシートが見つかりません。" & vbCrLf & _
"マクロを終了します。", vbExclamation, "無効なシート名"
Exit Sub
Else
Set PasteSheet = Sheets(PasteSheetName)
End If

LastRow = CopySheet.Range(KeyColumn & RowS.Count).End(xlUp).Row
If LastRow <= FirstRow Then
MsgBox "コードが見つかりません。" & vbCrLf & _
"マクロを終了します。", vbExclamation, "データ無し"
Exit Sub
End If

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
With PasteSheet
.Columns("C:D").Insert
Set myRange = .Range(LeftColumn & FirstRow & ":" & RightColumn & LastRow)
myRange.Value = CopySheet.Range(myRange.Address).Value
With Range(KeyColumn & FirstRow)
If .Value = "" Then .Value = "コード"
End With

myRange.AutoFilter Field:=Columns(LeftColumn & ":" & KeyColumn).Columns.Count, _
Criteria1:=Array("9999", "0", "="), Operator:=xlFilterValues
myRange.Offset(1).SpecialCells(xlCellTypeVisible).Delete Shift:=xlUp
.Cells.AutoFilter
.Columns(DeleteColumn).Delete
End With
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True

End Sub

お礼

これはタイトル行もとれていいですね。
勉強上はちょっとむずかしいです。
ありがとうございました。

回答No.6

mt2008

誤記訂正(^^;

誤：エラーの場合のコードが9999でなく、何か文字列になる場合は、セルC2に入れる条件を
↓
正：エラーの場合のコードが9999でなく、何か文字列になる場合は、セルE2に入れる条件を

お礼

了解しました。

回答No.5

mt2008

フィルター機能を使ってデータを抽出するのが簡単だと思います。
メニュー操作からのフィルターオプションでは、別シートへの抽出は出来ませんが、VBAではシートを指定する事で可能になります。

Sheet2を予め添付の図の様にしておきます。
抽出したい項目名をA1:C1に入れておきます。また、今回はE1:F2を抽出条件に使っています。
例では、「コードが9999でない」and「コードが0より大きい」が抽出条件になります。
＃枠線は有っても無くても良いです。

後はこれだけ。
Sub Sample()
　　Sheets("Sheet1").Columns("A:E").AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=Sheets("Sheet2").Range("E1:F2"), CopyToRange:=Sheets("Sheet2").Range("A1:C1")
End Sub

エラーの場合のコードが9999でなく、何か文字列になる場合は、セルC2に入れる条件を<=9999999 の様にコードの最大値以下と言う条件に変更します。

お礼

ありがとうございます。
が、フィルタオプション(AdvancedFilter) や条件セルを入れる場所が元データにはありません。

回答No.4

kagakusuki

1行ごとに処理するのではなく、まとめて一気にコピーするやり方の一例その2

Sub QNo8985905_Excel_任意の列の特定の行のみ値の取得_その2()

Dim CopySheet As Worksheet, PasteSheet As Worksheet, _
CopySheetName As String, PasteSheetName As String, _
KeyColumn As String, LeftColumn As String, _
CopyColumns As String, FirstRow As Long, LastRow As Long, _
ExcluVal(1) As Variant, i As Long

CopySheetName = "Sheet1" ' コピー元のシートのシート名
PasteSheetName = "Sheet2" ' 貼り付け先のシートのシート名
FirstRow = 1 ' コピー元のシートにおいて項目欄として使用されている行
LeftColumn = "A" ' 元データが入力されている左端の列
KeyColumn = "A" ' エラーコードが入力されている列
CopyColumns = "A:B,E:E" ' コピー元の列範囲
ExcluVal(0) = 0 ' 除外するコードの値　その1
ExcluVal(1) = 9999 ' 除外するコードの値　その2

If IsError(Evaluate("ROW('" & CopySheetName & "'!A1)")) Then
MsgBox "元データのシートとして登録されている" & vbCrLf _
& vbCrLf & CopySheetName & vbCrLf & vbCrLf & _
"というシート名のシートが見つかりません。" & vbCrLf & _
"マクロを終了します。", vbExclamation, "無効なシート名"
Exit Sub
Else
Set CopySheet = Sheets(CopySheetName)
End If
If IsError(Evaluate("ROW('" & PasteSheetName & "'!A1)")) Then
MsgBox "貼り付け先のシートとして登録されている" & vbCrLf _
& vbCrLf & PasteSheetName & vbCrLf & vbCrLf & _
"というシート名のシートが見つかりません。" & vbCrLf & _
"マクロを終了します。", vbExclamation, "無効なシート名"
Exit Sub
Else
Set PasteSheet = Sheets(PasteSheetName)
End If

LastRow = CopySheet.Range(KeyColumn & RowS.Count).End(xlUp).Row
If LastRow <= FirstRow Then
MsgBox "コードが見つかりません。" & vbCrLf & _
"マクロを終了します。", vbExclamation, "データ無し"
Exit Sub
End If

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

With CopySheet
.Columns(1).Insert
With .Range("A" & FirstRow & ":A" & LastRow)
.Value = .Offset(, Columns(KeyColumn).Column).Value
For i = 0 To UBound(ExcluVal)
.Replace What:=ExcluVal(i), Replacement:="", LookAt:=xlWhole
Next i
If .Resize(1, 1).Value = "" Then .Resize(1, 1).Value = " "

Application.Intersect(CopySheet.Range(CopyColumns).Offset(, 1), .SpecialCells(xlCellTypeConstants).EntireRow).Copy
PasteSheet.Range(LeftColumn & FirstRow).PasteSpecial Paste:=xlPasteValues
End With
.Columns(1).Delete
End With

Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True

End Sub

お礼

ありがとうございました。

回答No.2

mt2008

4行目のパンツAと15行目のジャケットCのコードが9999なのに除外対象になっていない理由は何でしょう。
他にも条件が有るのではないですか？

お礼

対象になっています。

回答No.1

keithin

＞根本的な…概念がわかっていません。

「何かをしない」じゃなく、あなたが具体的にヤリタイ（マクロにやらせたい）事は何か、というだけお話です。
何をシタイ（したくないじゃなく）のか「論理的」に説明できるようアタマを絞って整理すれば、マクロも自ずから明らかになります。

１．Ａ列が
　　9999じゃなく
　かつ　特定文字列じゃなく
　かつ　空白じゃなく
　かつ　０でもない
　　行を対象にしたい

２．指定の列、Ａ，Ｂ，Ｅ列を対象にしたい

３．対象のセルの値をシート２のＡ，Ｂ，Ｃ列に上から順繰り貼り付けたい

’ロジックの判りやすさを優先した遅いマクロによる一例：
sub macro3()
　dim r as long
　dim h as long
　h = 1

’シート２準備は省略

　worksheets("Sheet1").select
　for r = 2 to range("A65536").end(xlup).row

　’ヤリタイ事その１
　　if cells(r, "A") <> 9999 then
　　if cells(r, "A") <> "特定の文字列" then
　　if cells(r, "A") <> "" then
　　if cells(r, "A") <> 0 then

　　’ヤリタイことその３
　　　h = h + 1

　　’ヤリタイ事その２
　　　’Ａ列からＡ列に　
　　　worksheets("Sheet2").cells(h, "A").value = cells(r, "A").value
　　　’Ｂ列からＢ列に
　　　worksheets("Sheet2").cells(h, "B").value = cells(r, "B").value
　　　’Ｅ列からＣ列に
　　　worksheets("Sheet2").cells(h, "C").value = cells(r, "E").value
　　end if
　　end if
　　end if
　　end if
　next r
end sub

お礼

これです、これ。
ありがとうございます。
各行の動作が理解できました。
必要な列（A,B,E）の1行目（タイトル行）をSheet2の最初の列にもってくるのに苦労しました。

「’ヤリタイ事その１」の考え方として、Ifで条件に該当しないという条件を上げた上で、データ（値）をSheet2に集める考え方よりも、本当は条件に該当する列だけを集める方法が今後必要になるのですが、それはまた別の質問を立てる予定です。