Excelの表を纏めたいのですが、VBAで一発で振り分けすることはできませんか?

Excelの表を纏めたいのですが、VBAで一発で振り分けすることはできませんか? 画像を参照していただきたいのですが、 一覧表と言うシートには全ての品名と数量が入力されております。 その内容をA社・B社・C社シートへそれぞれ数値を(文字列として)振り分けたいです。(各シートには品名は既に入力済み) また、A社・B社・C社シートに無い品名についてはその他シートへ品名と数量の二つの内容を入力したいです。 実際の業務では品名の数と並びはランダムです。 何卒よろしくお願いいたします。

画像

Excel | Visual Basic41閲覧

ベストアンサー

0

少し見直したので再掲載します。 "一覧表"と"その他"以外のシートは会社のシートとして処理するので、名前も数も変更してもVBAに変更は不要です。 Sub sample() Dim wsL As Worksheet Dim wsO As Worksheet Dim lastRow As Long Dim ws As Worksheet Set wsL = Sheets("一覧表") Set wsO = Sheets("その他") lastRow = wsL.Range("A" & Rows.Count).End(xlUp).Row wsL.Range("A2:A" & lastRow).Copy wsO.Range("A2") For Each ws In Sheets If ws.Name <> wsL.Name And ws.Name <> wsO.Name Then With wsO.Range("B2:B" & lastRow) .NumberFormat = "General" .Formula = "=IF(A2="""","""",IF(ISERROR(MATCH(A2," & ws.Name & "!A:A,0)),A2,""""))" .Value = .Value .Offset(, -1).Value = .Value .ClearContents .NumberFormat = "@" End With End If Next wsO.Range("A:A").SpecialCells(xlCellTypeBlanks).Delete Shift:=xlUp For Each ws In Sheets If ws.Name <> wsL.Name Then With ws.Range("B2:B" & ws.Range("A" & Rows.Count).End(xlUp).Row) .NumberFormat = "General" .Formula = "=IFERROR(VLOOKUP(A2,一覧表!A:B,2,FALSE),"""")" .Value = .Value .NumberFormat = "@" End With End If Next End Sub

ThanksImg質問者からのお礼コメント

ありがとうございます。 上手くいきました。 感謝しております^_^

お礼日時:9/26 15:31

その他の回答(3件)

0

'(動作条件) '一覧表はA1セルから作成されていること '一覧表以外のシート上の入力表?はどの位置でもOKです(タイトル品名を検索します) Sub a() Dim Hinmei As Range Dim strName() As String Dim mySht As Worksheet Dim wsf As WorksheetFunction Dim i As Integer Dim cnt As Integer Set wsf = WorksheetFunction For Each mySht In Worksheets If mySht.Name <> "一覧表" And mySht.Name <> "その他" Then Set Hinmei = mySht.Cells.Find(What:="品名", After:=Cells(1), LookIn:=xlValues, LookAt:=xlWhole) For i = Hinmei.Offset(1, 0).Row To Hinmei.End(xlDown).Row mySht.Cells(i, Hinmei.Column + 1) = _ wsf.VLookup(mySht.Cells(i, Hinmei.Column), Worksheets("一覧表").Columns("A:B"), 2, False) ReDim Preserve strName(cnt) strName(cnt) = mySht.Cells(i, Hinmei.Column) cnt = cnt + 1 Next i End If Next mySht Dim exsistName As String Dim j As Integer Dim k As Integer Dim myFlg As Boolean Dim wsSonota As Worksheet Set wsSonota = Worksheets("その他") i = 2 k = 1 Do While Worksheets("一覧表").Cells(i, "A") <> "" myFlg = False exsistName = Worksheets("一覧表").Cells(i, "A").Value For j = LBound(strName) To UBound(strName) If exsistName = strName(j) Then myFlg = True Exit For End If Next j i = i + 1 If myFlg = False Then With wsSonota.Cells.Find(What:="品名", After:=wsSonota.Cells(1), LookAt:=xlWhole) .Offset(k, 0).Value = exsistName .Offset(k, 1).Value = wsf.VLookup(exsistName, Worksheets("一覧表").Columns("A:B"), 2, False) End With k = k + 1 End If Loop End Sub

0

5つのシート上の表は、いずれもA1から始まるものとしています。 Sub sample() Dim xDic, xComps, xComp, rng As Range, sh As Worksheet Set xDic = CreateObject("Scripting.Dictionary") Const xAll As String = "一覧表" Set sh = Worksheets("その他") Application.ScreenUpdating = False For Each xComp In Split("A社・B社・C社", "・") With Worksheets(xComp).Range("A1").CurrentRegion.Columns(1) For Each rng In .Offset(1).Resize(.Rows.Count - 1).Cells On Error Resume Next With rng xDic.Add .Value, "'" & xComp & "'!" & .Offset(, 1).Address End With On Error GoTo 0 Next rng End With Next xComp With Worksheets(xAll).Range("A1").CurrentRegion.Columns(1) For Each rng In .Offset(1).Resize(.Rows.Count - 1).Cells With rng If xDic.Exists(.Value) Then Range(xDic.Item(.Value)).Value = .Offset(, 1).Value Else sh.Cells(Rows.Count, 1).End(xlUp).Offset(1).Resize(, 2).Value = .Resize(, 2).Value End If End With Next rng End With Application.ScreenUpdating = True End Sub

1

一例です。 一覧表、各社シート共に、品名のダブリが無い、 各社シート内でも品名のダブリが無い、 また、表は各シートのA1を起点としている、 を前提としています。 コードの使用・改変は自由にしていただいて構いませんが、 他の掲示板・スレへの転載はご遠慮下さい。 他で使用する場合は必ずこのスレへのリンクにてお願いします。 Sub sample1() Dim myDIC As Object Dim myKey As Variant Dim myR As Long, myC As Long Dim mySheet(4) As Worksheet Set mySheet(0) = Worksheets("一覧表") Set mySheet(1) = Worksheets("A社") Set mySheet(2) = Worksheets("B社") Set mySheet(3) = Worksheets("C社") Set mySheet(4) = Worksheets("その他") Set myDIC = CreateObject("Scripting.Dictionary") With mySheet(0)     For myR = 2 To .Cells(.Rows.Count, 1).End(xlUp).Row         myDIC(.Cells(myR, 1).Value) = .Cells(myR, 2).Value     Next myR End With For myC = 1 To 3     With mySheet(myC)         For myR = 2 To .Cells(.Rows.Count, 1).End(xlUp).Row             .Cells(myR, 2).NumberFormatLocal = "@"             If myDIC.Exists(.Cells(myR, 1).Value) Then                 .Cells(myR, 2).Value = myDIC(.Cells(myR, 1).Value)                 myDIC.Remove (.Cells(myR, 1).Value)             Else                 .Cells(myR, 2).Value = Empty             End If         Next myR     End With Next myC If myDIC.Count > 0 Then     With mySheet(4)         myR = 1         For Each myKey In myDIC.Keys             myR = myR + 1             .Cells(myR, 2).NumberFormatLocal = "@"             .Cells(myR, 1).Value = myKey             .Cells(myR, 2).Value = myDIC(myKey)         Next myKey     End With End If Erase mySheet Set myDIC = Nothing End Sub 追加オーダーはご容赦下さい。

1人がナイス!しています