こんにちはゲストさん。会員登録(無料)して質問・回答してみよう!

-広告-

締切り済みの質問

VBA エクセル 抽出(転記)

sheets1
    A   B    C    D     E     F    G
1  品目  日付  在庫数  輸送手段  注文数  賞味期限 注文納期 
2  りんご  1/17  5    トラック    50     2/5    1/20
3  りんご  1/20  8    船      20      2/17   1/25
4  ぶどう  1/15  8    トラック   100     1/30    1/20
5  パイン  1/16  500   飛行機    200     2/20    2/1
6  バナナ  1/13  500   飛行機    1000    2/25    2/10
7  バナナ  1/15  10    トラック   400    3/1     2/24

sheets2 マスター
   りんご
   バナナ
sheets3 抽出+転記
   品目   注文数  注文納期
   りんご   50   1/20
   りんご   20   1/25
   バナナ   1000  2/10
   バナナ   400   2/24
という具合にVBAでsheets3に白紙の状態から抽出と転記ができるよう教えて頂き、順調に動いております。
自分が全くの初心者で申し訳ないのですが、ここからプラスαができません。
sheets2 マスター 
  品目    産地
  りんご   青森  
  バナナ   フィリピン
という具合にマスターsheets2 産地もsheets3に転記したいのですが、
どうアレンジしたらよいのか分かりません。教えてください。
下記のようにしたいです。
 品目   注文数  注文納期  産地
   りんご   50   1/20  青森
   りんご   20   1/25  青森
   バナナ   1000  2/10  フィリピン
   バナナ   400   2/24  フィリピン

投稿日時 - 2016-01-29 19:10:58

QNo.9119028

困ってます

このQ&Aは役に立ちましたか?

0人が「このQ&Aが役に立った」と投票しています

-広告-
-広告-

回答(3)

ANo.3

「Sheet3」には、項目名が1行目に、すでに入力されているという前提条件です。

途中からではなく、すべての処理を含んでいます。

Sub Test()
Dim a As String
Dim c, i, j, r1, r2 As Integer
r1 = Worksheets(1).Cells(Rows.Count, 1).End(xlUp).Row
r2 = Worksheets(2).Cells(Rows.Count, 1).End(xlUp).Row
c = 1
For i = 2 To r2
a = Worksheets(2).Cells(i, 1).Value
For j = 2 To r1
If a = Worksheets(1).Cells(j, 1).Value Then
c = c + 1
Worksheets(3).Cells(c, 1).Value = a
Worksheets(3).Cells(c, 2).Value = Worksheets(1).Cells(j, 5).Value
Worksheets(3).Cells(c, 3).Value = Worksheets(1).Cells(j, 7).Value
Worksheets(3).Cells(c, 4).Value = Worksheets(2).Cells(i, 2).Value
End If
Next j
Next i
End Sub

投稿日時 - 2016-01-30 21:04:47

ANo.2

Sub QNo9119028_VBA_エクセル_抽出_転記()

Const SearchColumn = "A" '元データシートの中で品目が入力されている列の列番号
Const SearchValueColumn = "A" 'マスターシートの中で品目が入力されている列の列番号
Const ItemRow = 1 '元データシートの中で項目名が入力されている行の行番号
Dim mySheet(2) As Worksheet, mySheetName(2) As String, CopyColumn As Variant _
, i As Long, c As Range, myBoolean As Boolean, LastRow As Long, LastColumn As Long

mySheetName(0) = "Sheet1" '元データがあるシートのシート名
mySheetName(1) = "Sheet2" 'マスターシートのシート名
mySheetName(2) = "Sheet3" '抽出結果を表示するシートのシート名
CopyColumn = Array("A", "E", "G") '抽出する列の列番号

For i = 0 To 2
If IsError(Evaluate("ROW('" & mySheetName(i) & "'!A1)")) Then
MsgBox "元データが入力されているシートとして設定されている" _
& vbCrLf & vbCrLf & mySheetName(i) & vbCrLf & vbCrLf & _
"というシート名のシートが見つかりません。" & vbCrLf _
& "マクロを終了します。", vbExclamation, "存在しないシート"
Exit Sub
Else
Set mySheet(i) = Sheets(mySheetName(i))
End If
Next i

With mySheet(0)
LastRow = .Range(SearchColumn & Rows.Count).End(xlUp).row
LastColumn = .Cells(ItemRow, Columns.Count).End(xlToLeft).column
End With
If LastRow <= ItemRow Or _
LastColumn < Columns(CopyColumn(UBound(CopyColumn))).column Then
MsgBox "処理すべきデータがありません。" & vbCrLf & "マクロを終了します。" _
, vbExclamation, "データ無し"
Exit Sub
End If

With Application
.ScreenUpdating = False
.Calculation = xlManual
End With

With mySheet(0)
For Each c In _
.Range(.Range(SearchColumn & ItemRow), .Cells(ItemRow, LastColumn))
myBoolean = False
For i = 0 To UBound(CopyColumn)
myBoolean = c.Address = "$" & CopyColumn(i) & "$" & ItemRow
If myBoolean Then Exit For
Next i
If Not myBoolean Then c.EntireColumn.Hidden = True
Next c
.Columns(1).Insert
.Cells(ItemRow, 1).Value = True
.Range("A" & ItemRow + 1 & ":" & "A" & LastRow).FormulaR1C1 _
= "=COUNTIF('" & mySheetName(1) & "'!C" & Columns(SearchValueColumn).column _
& ",RC" & Columns(SearchColumn).column + 1 & ")>0"
.Calculate
.Range("A" & ItemRow & ":" & "A" & LastRow).AutoFilter Field:=1, Criteria1:=True
.Range(CopyColumn(0) & ItemRow & ":" & CopyColumn(UBound(CopyColumn)) & LastRow) _
.Offset(0, 1).SpecialCells(xlCellTypeVisible).Copy
End With

With mySheet(2).Range(CopyColumn(0) & ItemRow)
.PasteSpecial Paste:=xlPasteFormats
.PasteSpecial Paste:=xlPasteValues
With .Resize(.Range(CopyColumn(0) & Rows.Count).End(xlUp).row - ItemRow + 1).Offset(, UBound(CopyColumn) + 1)
.FormulaR1C1 = "=IF(RC1="""","""",VLOOKUP(RC1,'Sheet46 (5)'!C1:C2,2,FALSE))"
.Parent.Calculate
.Value = .Value
End With
End With

With mySheet(0)
.Cells.AutoFilter
.Columns(1).Delete
.Cells(ItemRow, 1).Resize(1, LastColumn).EntireColumn.Hidden = False
End With

With Application
.CutCopyMode = False
.Calculation = xlAutomatic
.ScreenUpdating = True
End With

End Sub

投稿日時 - 2016-01-29 21:54:16

ANo.1

まとめて一気に転記するだけです。

sub macro2()

’シート1からシート3のA,B,C列に転記した続きから

 with worksheets("Sheet3")
 if .range("A2") = "" then exit sub
 with .range("D2:D" & .range("A65536").end(xlup).row)
  .formula = "=VLOOKUP(A2,Sheet2!A:B,2,FALSE)"
  .value = .value
 end with
 end with
end sub

投稿日時 - 2016-01-29 20:06:53

-広告-
-広告-

あなたにオススメの質問

-広告-
-広告-