Results of 1 - 1 of about 37700 for IF (0.007 sec.)
- [[20120416110515]]
- #score: 1591
- @digest: ce2923f77ed2aa2935557a5f4ca5d81f
- @id: 58570
- @mdate: 2012-04-17T09:23:54Z
- @size: 42857
- @type: text/plain
- #keywords: vntdataa (300143), wksrst (252382), vntdatab (239949), vntsheet (237618), 庫b (235173), 庫a (208982), 倉庫 (164590), lngwite (152345), clnglimit (149876), 記po (141118), getsheet (133742), postdata (119143), 形3 (94669), rnglistb (93614), rnglista (93614), lngcompa (92810), lngcompb (92023), wksmark (91035), vntname (90524), 雛形 (90081), lnggap (84656), lnglimit (82886), clngcolumnsa (79180), 較位 (78787), vntnumb (78698), lngindex (76548), lngflag (75264), datacompare (74108), lngrowsb (72092), 形2 (68958), vntdata (42507), 形1 (39434)
- 『マクロで2つのデータを比較』（きゃとら）
以前も似たような質問でお世話になったのですが 下記のようなデータがあるとします。 A B C D E F G 1 倉庫A 倉庫B 2 記号 品名 数量 記号 品名 数量 3 Ap_A りんご 150 Ap_B りんご 300 4 Or_A みかん 20 Gp_B ぶどう 400 5 Gp_A ぶどう 2500 Sb_B いちご 100 6 Sb_A いちご 200 Ml_B メロン 2400 7 Ml_A メロン 2100 Lm_B レモン 2600 やりたいことは、「雛形1」「雛形2」「雛形3」というシートがあり、上のデータに基づいて 雛形をコピーして使うのですが、 ・「倉庫A」と「倉庫B」のデータを比較して、「両方にあるもの」「左側にしかないもの」「右側にしかないもの」を探し出す（品番の先頭2文字で判定） ↓ ・「両方に値があり、かつ両方とも数量が2000未満」→「雛形1」シートをコピー ・「片方にしか値がなく、かつ数量が2000未満」→「雛形2」をコピー ・「両方に値があり、かつ片方が2000以上でもう片方が2000未満」→「雛形2」「雛形3」をコピー ・「片方にしか値がなく、かつ2000以上」→「雛形3」コピー ・「両方に値があり、両方とも2000以上」→「雛形3」コピー 左にあって右にないものを探し出すコードは http://vbae.odyssey-com.co.jp/column/no23_4.html これで分かったのですが、両方を比較してそれぞれの有る無しを判定するにはどうすればよいでしょうか。 Excel2007です。 ---- 倉庫A、倉庫B其々の倉庫内で記号の重複は在りますか? もし在るなら、其れをどの様に比較すればいいのですか? (Bun) ---- 記号の重複はないです。 全てユニークの記号になっています。 （きゃとら） ---- 後、善く見ていたら >・「両方に値があり、かつ両方とも数量が2000未満」→「雛形1」シートをコピー >・「片方にしか値がなく、かつ数量が2000未満」→「雛形2」をコピー >・「両方に値があり、かつ片方が2000以上でもう片方が2000未満」→「雛形2」「雛形3」をコピー >・「片方にしか値がなく、かつ2000以上」→「雛形3」コピー >・「両方に値があり、両方とも2000以上」→「雛形3」コピー この「コピー」とは、どう言う意味ですか? 単にシートをCopyするだけですか? それとも、シートをCopyして其処へ転記すするのですか? それともう一つ、倉庫A、倉庫Bのデータは整列変えをしても善いですか? (Bun) ---- 雛形をコピーして、その中に「記号」「品名」「数量」などのデータを転記します。 ＞それともう一つ、倉庫A、倉庫Bのデータは整列変えをしても善いですか? すみません、並びは変えられないんです… （きゃとら） ---- >雛形をコピーして、その中に「記号」「品名」「数量」などのデータを転記します。 其れ成らば、コピーした雛形のシート名はどうするの? 其れと転記する、シートの位置は如何します? >すみません、並びは変えられないんです… 此れは了解しました 後で消去しますが作業列を作るかも? また、データの量は多いのですか? (Bun) ---- シート名は AP【りんご】、AP【りんご】(2)（同じ名前のシートが作成された場合）のようにします。 コピーしたシートはブックの最後尾に追加します。 データの量は50行ぐらいです。 （きゃとら） ---- こんなかな? 50行程度なので処理速度は考えていません Option Explicit Public Sub Sample() '倉庫Aのデータ列数（A列〜C列） Const clngColumnsA As Long = 3 '倉庫Aの中の比較する列位置(基準列A列からの列Offset:0列目) Const clngKeyA As Long = 0 '倉庫Bのデータ列数（E列〜G列） Const clngColumnsB As Long = 3 '倉庫Bの中の比較する列位置(基準列E列からの列Offset:0列目) Const clngKeyB As Long = 0 '出力するシートの出力セル先頭位置 Const cstrTop As String = "A2" '区分けする値 Const clngLimit As Long = 2000 Dim i As Long Dim lngRowsA As Long Dim rngListA As Range Dim lngRowsB As Long Dim rngListB As Range Dim rngRlt() As Range Dim lngWite() As Long Dim vntDataA As Variant Dim vntDataB As Variant Dim lngFlag() As Long Dim vntSheet As Variant Dim dicIndex As Object Dim vntKey As Variant Dim strProm As String '雛形に成るシート名 vntSheet = Array("雛形1", "雛形2", "雛形3") ReDim lngWite(UBound(vntSheet, 1)), rngRlt(UBound(vntSheet, 1)) '倉庫Aの先頭セル位置を基準とする（先頭列の列見出し「記号」のセル位置） Set rngListA = Worksheets("Sheet1").Range("A2") '倉庫Bの先頭セル位置を基準とする（先頭列の列見出し「記号」のセル位置） Set rngListB = Worksheets("Sheet1").Range("E2") 'Dictionaryオブジェクトを取得 Set dicIndex = CreateObject("Scripting.Dictionary") With rngListA '行数の取得 lngRowsA = .Offset(Rows.Count - .Row, clngKeyA).End(xlUp).Row - .Row If lngRowsA <= 0 Then strProm = "データが有りません" GoTo Wayout End If End With With rngListB '行数の取得 lngRowsB = .Offset(Rows.Count - .Row, clngKeyB).End(xlUp).Row - .Row If lngRowsB <= 0 Then strProm = "データが有りません" GoTo Wayout End If '列データを配列に取得 vntDataB = .Offset(1).Resize(lngRowsB, clngColumnsB).Value '転記Flagを立てる配列を確保 ReDim lngFlag(1 To lngRowsB) End With '画面更新を停止 Application.ScreenUpdating = False '雛形をCopy strProm = "雛形シートが在りません" On Error GoTo Wayout With Worksheets For i = 0 To UBound(vntSheet) Worksheets(vntSheet(i)).Copy After:=.Item(.Count) Set rngRlt(i) = ActiveSheet.Range(cstrTop) Next i End With On Error GoTo 0 With dicIndex '倉庫Bの登録 For i = 1 To lngRowsB 'Dictionaryに倉庫Bの「記号」2文字を登録 .Item(Left(vntDataB(i, 1), 2)) = i '数量が指定量未満の場合 If vntDataB(i, 3) < clngLimit Then lngFlag(i) = 1 Else lngFlag(i) = 2 End If Next i '倉庫Aの「記号」2文字を上から見て行って For i = 1 To lngRowsA '出力用配列にデータを取得 vntDataA = rngListA.Offset(i).Resize(, clngColumnsA).Value '「記号」から2文字切り出し vntKey = Left(vntDataA(1, 1), 2) '倉庫Bの中に倉庫Aが有った場合 If .Exists(vntKey) Then '数量が共に指定量未満なら If vntDataA(1, 3) < clngLimit _ And vntDataB(.Item(vntKey), 3) < clngLimit Then '倉庫Aを転記 lngWite(0) = lngWite(0) + 1 rngRlt(0).Offset(lngWite(0)).Resize(, clngColumnsA).Value = vntDataA '倉庫Bの転記指示を変更 lngFlag(.Item(vntKey)) = 0 '倉庫Aが指定量未満で、倉庫Bが指定量以上なら ElseIf vntDataA(1, 3) < clngLimit _ And vntDataB(.Item(vntKey), 3) >= clngLimit Then '倉庫Aを転記 lngWite(1) = lngWite(1) + 1 rngRlt(1).Offset(lngWite(1)).Resize(, clngColumnsA).Value = vntDataA '倉庫Bの転記指示を変更 lngFlag(.Item(vntKey)) = 2 '倉庫Aが指定量以上で、倉庫Bが指定量未満なら ElseIf vntDataA(1, 3) >= clngLimit _ And vntDataB(.Item(vntKey), 3) < clngLimit Then '倉庫Aを転記 lngWite(2) = lngWite(2) + 1 rngRlt(2).Offset(lngWite(2)).Resize(, clngColumnsA).Value = vntDataA '倉庫Bの転記指示を変更 lngFlag(.Item(vntKey)) = 1 Else '倉庫Aを転記 lngWite(2) = lngWite(2) + 1 rngRlt(2).Offset(lngWite(2)).Resize(, clngColumnsA).Value = vntDataA '倉庫Bの転記指示を変更 lngFlag(.Item(vntKey)) = 2 End If Else If vntDataA(1, 3) < clngLimit Then '倉庫Aを転記 lngWite(1) = lngWite(1) + 1 rngRlt(1).Offset(lngWite(1)).Resize(, clngColumnsA).Value = vntDataA Else '倉庫Aを転記 lngWite(2) = lngWite(2) + 1 rngRlt(2).Offset(lngWite(2)).Resize(, clngColumnsA).Value = vntDataA End If End If Next i End With '倉庫Bを転記 For i = 1 To lngRowsB vntDataB = rngListB.Offset(i).Resize(, clngColumnsB).Value lngWite(lngFlag(i)) = lngWite(lngFlag(i)) + 1 rngRlt(lngFlag(i)).Offset(lngWite(lngFlag(i))).Resize(, clngColumnsB).Value = vntDataB Next i '転記が行われ無かったシートが在れば削除 Application.DisplayAlerts = False For i = 0 To UBound(vntSheet) If lngWite(i) = 0 Then rngRlt(i).Parent.Delete End If Next i Application.DisplayAlerts = True strProm = "処理が完了しました" Wayout: '画面更新を再開 Application.ScreenUpdating = True For i = 0 To UBound(vntSheet) Set rngRlt(i) = Nothing Next i Set dicIndex = Nothing Set rngListA = Nothing Set rngListB = Nothing MsgBox strProm, vbInformation End Sub (Bun) ---- Bun様 ありがとうございます。 実行してみましたが、雛形1〜3がそれぞれ1枚ずつコピーされ、その中にデータが入っただけでシート名も変わりませんでした。 …とここまで書いて気付いたのですが、私の説明不足でした。 恐らくBun様は ・「両方に値があり、かつ両方とも数量が2000未満」→「雛形1」シートをコピー 上記に該当するものをまとめて「雛形1」をコピーしたものに転記 と受け取られたのではないかと… すみません、もう一度ご説明いたします。 このマクロは、最初のデータを元に帳票を作るためのものです。 同じ「商品」ごとに、データが有るか無いか、2000件を超えるか超えないかを判断して、1商品に1〜2枚の帳票が作成されます。 その「帳票」が雛形になっており、下記のような構成になっています。 ○雛形1（数量2000未満のものが一つのシートに2つ記載される） A B C D E 〜 K 〜 P 1 2 3 4 AP りんご 5 6 7 Ap_A 150 8 : : : 23 Ap_B 300 E4に記号の先頭2文字 P4に品名 C7に倉庫Aの記号 K7に倉庫Aの数量 C23に倉庫Bの記号 K23に倉庫Bの数量 ○雛形2（数量2000未満のものが1つ記載される） A B C D E 〜 K 〜 P 1 2 3 4 Or みかん 5 6 7 Or_A 20 ○雛形3（数量2000以上のものが1つ記載される） A B C D E 〜 K 〜 P 1 2 3 4 Lm レモン 5 6 7 Lm_B 2600 ※雛形2と3は転記する場所のレイアウトは同じです。 (下に手書きする作業列があるかないかの違い） ○雛形1を使う場合 ・両方にデータがあり、両方とも数量が2000未満の場合 ○雛形2を使う場合 ・両方にデータがあり、片方が2000以上で、もう片方が2000未満の場合の2000未満の商品 ・片方だけにデータがあり、数量が2000未満の場合 ○雛形3を使う場合 ・両方にデータがあり、両方が2000以上の場合 ・両方にデータがあり、片方が2000以上の場合の2000以上の商品 ・片方にデータがあり、数量が2000以上の場合 このようになっています。 なので、上記のデータの例では ・りんご、いちご→雛形1をコピーしてデータを転記 ・みかん→雛形2をコピーしてデータを転記 ・ぶどう→雛形2と3をコピーしてそれぞれにデータを転記 ・メロン→雛形3を2枚コピーしてそれぞれにデータを転記 ・レモン→雛形3をコピーしてデータを転記 のようになります （きゃとら） ---- と言う事なら、処理方法を変更しました Option Explicit Public Sub DataMatch() '倉庫Aのデータ列数（A列〜C列） Const clngColumnsA As Long = 3 '倉庫Aの中の比較する列位置(基準列A列からの列Offset:0列目) Const clngKeyA As Long = 0 '倉庫Bのデータ列数（E列〜G列） Const clngColumnsB As Long = 3 '倉庫Bの中の比較する列位置(基準列E列からの列Offset:0列目) Const clngKeyB As Long = 0 '区分けする値 Const clngLimit As Long = 2000 Dim rngListA As Range Dim vntListA As Variant Dim lngRowsA As Long Dim lngCompA As Long Dim vntDataA As Variant Dim lngIdxA() As Long Dim rngListB As Range Dim vntListB As Variant Dim lngRowsB As Long Dim lngCompB As Long Dim vntDataB As Variant Dim lngIdxB() As Long Dim lngMatch As Long Dim wksRst As Worksheet Dim vntSheet As Variant Dim strProm As String '雛形に成るシート名 vntSheet = Array("雛形1", "雛形2", "雛形3") '倉庫Aの先頭セル位置を基準とする（先頭列の列見出し「記号」のセル位置） Set rngListA = Worksheets("Sheet1").Range("A2") '倉庫Bの先頭セル位置を基準とする（先頭列の列見出し「記号」のセル位置） Set rngListB = Worksheets("Sheet1").Range("E2") '画面更新を停止 Application.ScreenUpdating = False '倉庫Aの基準に就いて If Not GetBasicData(rngListA, lngRowsA, clngColumnsA, clngKeyA, vntListA, lngIdxA) Then strProm = rngListA.Parent.Name & "にデータが有りません" GoTo Wayout End If '倉庫B基準に就いて If Not GetBasicData(rngListB, lngRowsB, clngColumnsB, clngKeyB, vntListB, lngIdxB) Then strProm = rngListB.Parent.Name & "にデータが有りません" GoTo Wayout End If '倉庫Aのシートの比較位置 lngCompA = 1 '倉庫Bのシートの比較位置 lngCompB = 1 '倉庫Aのシート若しくは、倉庫Bのシートが最終行に達するまで繰り返し Do Until lngCompA > lngRowsA And lngCompB > lngRowsB '倉庫Aの1行分配列に取得 vntDataA = rngListA.Offset(lngIdxA(lngCompA)).Resize(, clngColumnsA).Value '倉庫Bの1行分配列に取得 vntDataB = rngListB.Offset(lngIdxB(lngCompB)).Resize(, clngColumnsB).Value '各列のデータを比較 lngMatch = DataCompare(vntListA, lngIdxA(lngCompA), vntListB, lngIdxB(lngCompB)) '比較結果に就いて Select Case lngMatch Case Is = 0 'Matchiした場合 '両方とも数量が2000未満の場合 If vntDataA(1, 3) < clngLimit And vntDataB(1, 3) < clngLimit Then '雛形1をCopy GetSheet vntSheet(0), vntDataA, wksRst 'データを転記 PostData wksRst, vntDataA, vntDataB '倉庫Aが2000以上で、倉庫Bが2000未満の場合 ElseIf vntDataA(1, 3) >= clngLimit And vntDataB(1, 3) < clngLimit Then '雛形3をCopy GetSheet vntSheet(2), vntDataA, wksRst '倉庫Aデータを転記 PostData wksRst, vntDataA, Empty '雛形2をCopy GetSheet vntSheet(1), vntDataB, wksRst '倉庫Bデータを転記 PostData wksRst, vntDataB, Empty '倉庫Bが2000以上で、倉庫Aが2000未満の場合 ElseIf vntDataA(1, 3) < clngLimit And vntDataB(1, 3) >= clngLimit Then '雛形2をCopy GetSheet vntSheet(1), vntDataA, wksRst '倉庫Aデータを転記 PostData wksRst, vntDataA, Empty '雛形3をCopy GetSheet vntSheet(2), vntDataB, wksRst '倉庫Bデータを転記 PostData wksRst, vntDataB, Empty '両方が2000以上の場合 Else '雛形3をCopy GetSheet vntSheet(2), vntDataA, wksRst '倉庫Aデータを転記 PostData wksRst, vntDataA, Empty '雛形3をCopy GetSheet vntSheet(2), vntDataB, wksRst '倉庫Bデータを転記 PostData wksRst, vntDataB, Empty End If '倉庫Aのシートの比較位置を更新 lngCompA = lngCompA + 1 '倉庫Bのシートの比較位置を更新 lngCompB = lngCompB + 1 Case Is = -1 '倉庫Aの固有値の場合 If vntDataA(1, 3) < clngLimit Then '雛形2をCopy GetSheet vntSheet(1), vntDataA, wksRst '倉庫Aデータを転記 PostData wksRst, vntDataA, Empty Else '雛形3をCopy GetSheet vntSheet(2), vntDataA, wksRst '倉庫Aデータを転記 PostData wksRst, vntDataA, Empty End If '倉庫Aのシートの比較位置を更新 lngCompA = lngCompA + 1 Case Is = 1 '倉庫Bの固有値の場合 If vntDataB(1, 3) < clngLimit Then '雛形2をCopy GetSheet vntSheet(1), vntDataB, wksRst '倉庫Aデータを転記 PostData wksRst, vntDataB, Empty Else '雛形3をCopy GetSheet vntSheet(2), vntDataB, wksRst '倉庫Aデータを転記 PostData wksRst, vntDataB, Empty End If '倉庫Bのシートの比較位置を更新 lngCompB = lngCompB + 1 End Select Loop strProm = "処理が完了しました" Wayout: '画面更新を再開 Application.ScreenUpdating = True Set rngListA = Nothing Set rngListB = Nothing Set wksRst = Nothing MsgBox strProm, vbInformation End Sub Private Sub GetSheet(vntCopy As Variant, vntData As Variant, wksMark As Worksheet) Dim i As Long Dim vntName As Variant Dim vntNumb As Variant If TypeName(Evaluate(vntCopy & "!A1")) <> "Range" Then Set wksMark = Nothing Exit Sub End If i = 1 vntName = Left(vntData(1, 1), 2) & "【" & vntData(1, 2) & "】" Do While TypeName(Evaluate(vntName & vntNumb & "!A1")) = "Range" i = i + 1 vntNumb = "(" & i & ")" Loop '雛形をCopy With Worksheets Worksheets(vntCopy).Copy After:=.Item(.Count) End With Set wksMark = ActiveSheet wksMark.Name = vntName & vntNumb End Sub Private Sub PostData(wksMark As Worksheet, vntData1 As Variant, vntData2 As Variant) If wksMark Is Nothing Then Exit Sub End If With wksMark .Range("E4").Value = Left(vntData1(1, 1), 2) .Range("P4").Value = vntData1(1, 2) .Range("C7").Value = vntData1(1, 1) .Range("K7").Value = vntData1(1, 3) If VarType(vntData2) = vbArray + vbVariant Then .Range("C23").Value = vntData2(1, 1) .Range("K23").Value = vntData2(1, 3) End If End With End Sub Private Function GetBasicData(rngList As Range, _ lngRows As Long, _ lngColumns As Long, _ lngKey As Long, _ vntData As Variant, _ lngIdx() As Long) As Boolean Dim i As Long '基準に就いて With rngList '行数を取得 lngRows = .Offset(Rows.Count - .Row, lngKey).End(xlUp).Row - .Row 'データが無ければFunctionを抜ける(戻り値=False) If lngRows <= 0 Then Exit Function End If '比較用配列に「記号」データを取得 vntData = .Offset(1, lngKey).Resize(lngRows + 1).Value '「記号」データを頭2文字にし、Indexを作成 ReDim lngIdx(1 To lngRows) For i = 1 To lngRows lngIdx(i) = i vntData(i, 1) = Left(vntData(i, 1), 2) Next i 'データを整列 ShellSort vntData, lngIdx End With GetBasicData = True End Function Private Function DataCompare(vntKeys1 As Variant, lngPos1 As Long, _ vntKeys2 As Variant, lngPos2 As Long) As Long ' データの大小比較 Dim i As Long '比較位置がDataEndを超えた場合 If lngPos1 > UBound(vntKeys1, 1) - 1 Then DataCompare = 1 Exit Function End If If lngPos2 > UBound(vntKeys2, 1) - 1 Then DataCompare = -1 Exit Function End If 'Keyが一致した場合 If vntKeys1(lngPos1, 1) = vntKeys2(lngPos2, 1) Then '戻り値の値として、「等しい」を返す DataCompare = 0 Else 'vntKeys1の値が、vntKeys2の値因り小さい場合 If vntKeys1(lngPos1, 1) < vntKeys2(lngPos2, 1) Then '戻り値の値として、「小さい」を返す DataCompare = -1 Else '戻り値の値として、「大きい」を返す DataCompare = 1 End If End If End Function Private Sub ShellSort(vntList As Variant, _ lngIndex() As Long, _ Optional lngKey As Long = 1) Dim i As Long Dim j As Long Dim lngGap As Long Dim lngTmp As Long Dim lngTop As Long Dim lngEnd As Long Dim blnCompare As Boolean lngTop = LBound(lngIndex, 1) lngEnd = UBound(lngIndex, 1) lngGap = 1 Do While lngGap < (lngEnd - lngTop + 1) ¥ 3 lngGap = 3 * lngGap + 1 Loop Do Until lngGap <= 0 For i = lngGap + lngTop To lngEnd For j = i To lngGap + lngTop Step -lngGap If vntList(lngIndex(j - lngGap), lngKey) > vntList(lngIndex(j), lngKey) Then lngTmp = lngIndex(j - lngGap) lngIndex(j - lngGap) = lngIndex(j) lngIndex(j) = lngTmp Else Exit For End If Next j Next i lngGap = lngGap ¥ 3 Loop End Sub (Bun) ---- Bun様 ありがとうございます。 やはりエラーが出ます。 「シートの名前を他のシート、VisualBasicで参照されるオブジェクト ライブラリまたはワークシートと 同じ名前に変更することはできません」 '雛形をCopy With Worksheets Worksheets(vntCopy).Copy After:=.Item(.Count) End With Set wksMark = ActiveSheet wksMark.Name = vntName & vntNumb ←ここでエラー それで、一部作成されたシートも、シート名が 【】 【】(2) 雛形1(2) となっていて、データは転記されていません。 あとすみません、最初のデータシートは、ところどころ、途中の行に2行目と同じ見出しが入ります。 入る行は毎日決まっていません。 これを書き忘れました… （きゃとら） ---- 取りあえず、エラー箇所の不都合が見つかったので以下のプロシージャ「Private Sub GetSheet」に差し替えて下さい Private Sub GetSheet(vntCopy As Variant, vntData As Variant, wksMark As Worksheet) ' 雛形シートをCopyして、名前を付ける Dim i As Long Dim j As Long Dim vntName As Variant Dim vntNumb As Variant '指定された雛形シートが在るかを確認 If TypeName(Evaluate(vntCopy & "!A1")) <> "Range" Then '無い場合は変数wksMarkをNothingにしてSubを抜ける Set wksMark = Nothing Exit Sub End If '予定するシート名に同名が在った時後ろに付けるカウントを初期値に i = 1 '予定シート名を作成 vntName = Left(vntData(1, 1), 2) & "【" & vntData(1, 2) & "】" '予定シート名がBookの中に無く成る迄繰り返し ' Do While TypeName(Evaluate(vntName & vntNumb & "!A1")) = "Range" ' 'カウントアップ ' i = i + 1 ' 'シート名に付けるカント文字を作成 ' vntNumb = "(" & i & ")" ' Loop Do For j = 1 To Worksheets.Count If Worksheets(j).Name = vntName & vntNumb Then Exit For End If Next j If j <= Worksheets.Count Then 'カウントアップ i = i + 1 'シート名に付けるカント文字を作成 vntNumb = "(" & i & ")" Else Exit Do End If Loop '雛形を最終シートの後ろにCopy With Worksheets Worksheets(vntCopy).Copy After:=.Item(.Count) End With 'Copyしたシートを変数に格納 Set wksMark = ActiveSheet 'シート名を変更 wksMark.Name = vntName & vntNumb End Sub コードの確認はこれからして見ます (Bun) ---- >あとすみません、最初のデータシートは、ところどころ、途中の行に2行目と同じ見出しが入ります。 >入る行は毎日決まっていません。 >これを書き忘れました… とすると、同じListに重複データが在る事に成るのでコードを書き換えなければならないと思いますので 確認の時間が掛かります (Bun) ---- 後、 >それで、一部作成されたシートも、シート名が >【】 >【】(2) >雛形1(2) 此れが出ているって事は、この比較する倉庫Aと倉庫BのListが在るシート名が コードで指定しているシートと違っていると思いますが確認して、違っているなら 以下をのシート名を変更して下さい '倉庫Aの先頭セル位置を基準とする（先頭列の列見出し「記号」のセル位置） Set rngListA = Worksheets("Sheet1").Range("A2") '倉庫Bの先頭セル位置を基準とする（先頭列の列見出し「記号」のセル位置） Set rngListB = Worksheets("Sheet1").Range("E2") の"Sheet1"と成っている所を比較する倉庫Aと倉庫BのListが在るシート名にして下さい (Bun) ---- 一応、列見出しが複数在る場合、シートCopyの不都合に就いての対処を行いました シート名は実際のシートの名前に変更して下さい Option Explicit Public Sub DataMatch_2() '倉庫Aのデータ列数（A列〜C列） Const clngColumnsA As Long = 3 '倉庫Aの中の比較する列位置(基準列A列からの列Offset:0列目) Const clngKeyA As Long = 0 '倉庫Bのデータ列数（E列〜G列） Const clngColumnsB As Long = 3 '倉庫Bの中の比較する列位置(基準列E列からの列Offset:0列目) Const clngKeyB As Long = 0 '区分けする値 Const clngLimit As Long = 2000 Dim rngListA As Range Dim vntListA As Variant Dim lngRowsA As Long Dim lngCompA As Long Dim vntDataA As Variant Dim lngIdxA() As Long Dim rngListB As Range Dim vntListB As Variant Dim lngRowsB As Long Dim lngCompB As Long Dim vntDataB As Variant Dim lngIdxB() As Long Dim lngMatch As Long Dim wksRst As Worksheet Dim vntSheet As Variant Dim strProm As String '雛形に成るシート名 vntSheet = Array("雛形1", "雛形2", "雛形3") '倉庫Aの先頭セル位置を基準とする（先頭列の列見出し「記号」のセル位置） Set rngListA = Worksheets("Sheet1").Range("A2") '倉庫Bの先頭セル位置を基準とする（先頭列の列見出し「記号」のセル位置） Set rngListB = Worksheets("Sheet1").Range("E2") '画面更新を停止 Application.ScreenUpdating = False '倉庫Aの基準に就いて If Not GetBasicData(rngListA, lngRowsA, clngColumnsA, clngKeyA, vntListA, lngIdxA) Then strProm = rngListA.Parent.Name & "にデータが有りません" GoTo Wayout End If '倉庫B基準に就いて If Not GetBasicData(rngListB, lngRowsB, clngColumnsB, clngKeyB, vntListB, lngIdxB) Then strProm = rngListB.Parent.Name & "にデータが有りません" GoTo Wayout End If '倉庫Aのシートの比較位置 lngCompA = 1 '倉庫Bのシートの比較位置 lngCompB = 1 '倉庫Aのシート若しくは、倉庫Bのシートが最終行に達するまで繰り返し Do Until lngCompA > lngRowsA And lngCompB > lngRowsB '倉庫Aの1行分配列に取得 vntDataA = rngListA.Offset(lngIdxA(lngCompA)).Resize(, clngColumnsA).Value '倉庫Bの1行分配列に取得 vntDataB = rngListB.Offset(lngIdxB(lngCompB)).Resize(, clngColumnsB).Value '各列のデータを比較 lngMatch = DataCompare(vntListA, lngIdxA(lngCompA), vntListB, lngIdxB(lngCompB)) '比較結果に就いて Select Case lngMatch Case Is = 0 'Matchiした場合 'Matchした時の処理を行う Match vntDataA, vntDataB, vntSheet, clngLimit '倉庫Aのシートの比較位置を更新 lngCompA = lngCompA + 1 '倉庫Bのシートの比較位置を更新 lngCompB = lngCompB + 1 Case Is = -1 '倉庫Aの固有値の場合 '片方にしか無い場合の処理 NoMatch vntDataA, vntSheet, clngLimit '倉庫Aのシートの比較位置を更新 lngCompA = lngCompA + 1 Case Is = 1 '倉庫Bの固有値の場合 '片方にしか無い場合の処理 NoMatch vntDataB, vntSheet, clngLimit '倉庫Bのシートの比較位置を更新 lngCompB = lngCompB + 1 End Select Loop strProm = "処理が完了しました" Wayout: '画面更新を再開 Application.ScreenUpdating = True Set rngListA = Nothing Set rngListB = Nothing Set wksRst = Nothing MsgBox strProm, vbInformation End Sub Private Sub GetSheet(vntCopy As Variant, vntData As Variant, wksMark As Worksheet) ' 雛形シートをCopyして、名前を付ける Dim i As Long Dim j As Long Dim vntName As Variant Dim vntNumb As Variant '指定された雛形シートが在るかを確認 If TypeName(Evaluate(vntCopy & "!A1")) <> "Range" Then '無い場合は変数wksMarkをNothingにしてSubを抜ける Set wksMark = Nothing Exit Sub End If '予定するシート名に同名が在った時後ろに付けるカウントを初期値に i = 1 '予定シート名を作成 vntName = Left(vntData(1, 1), 2) & "【" & vntData(1, 2) & "】" Do For j = 1 To Worksheets.Count If Worksheets(j).Name = vntName & vntNumb Then Exit For End If Next j If j <= Worksheets.Count Then 'カウントアップ i = i + 1 'シート名に付けるカント文字を作成 vntNumb = "(" & i & ")" Else Exit Do End If Loop '雛形を最終シートの後ろにCopy With Worksheets Worksheets(vntCopy).Copy After:=.Item(.Count) End With 'Copyしたシートを変数に格納 Set wksMark = ActiveSheet 'シート名を変更 wksMark.Name = vntName & vntNumb End Sub Private Sub Match(vntDataA As Variant, vntDataB As Variant, _ vntSheet As Variant, lngLimit As Long) ' 「記号」がMatchした場合の処理 Dim wksRst As Worksheet '結果を書き込むシート If Not IsNumeric(vntDataA(1, 3)) Then Exit Sub End If '両方とも数量が2000未満の場合 If vntDataA(1, 3) < lngLimit And vntDataB(1, 3) < lngLimit Then '雛形1をCopy GetSheet vntSheet(0), vntDataA, wksRst 'データを転記 PostData wksRst, vntDataA, vntDataB '倉庫Aが2000以上で、倉庫Bが2000未満の場合 ElseIf vntDataA(1, 3) >= lngLimit And vntDataB(1, 3) < lngLimit Then '雛形3をCopy GetSheet vntSheet(2), vntDataA, wksRst '倉庫Aデータを転記 PostData wksRst, vntDataA, Empty '雛形2をCopy GetSheet vntSheet(1), vntDataB, wksRst '倉庫Bデータを転記 PostData wksRst, vntDataB, Empty '倉庫Bが2000以上で、倉庫Aが2000未満の場合 ElseIf vntDataA(1, 3) < lngLimit And vntDataB(1, 3) >= lngLimit Then '雛形2をCopy GetSheet vntSheet(1), vntDataA, wksRst '倉庫Aデータを転記 PostData wksRst, vntDataA, Empty '雛形3をCopy GetSheet vntSheet(2), vntDataB, wksRst '倉庫Bデータを転記 PostData wksRst, vntDataB, Empty '両方が2000以上の場合 Else '雛形3をCopy GetSheet vntSheet(2), vntDataA, wksRst '倉庫Aデータを転記 PostData wksRst, vntDataA, Empty '雛形3をCopy GetSheet vntSheet(2), vntDataB, wksRst '倉庫Bデータを転記 PostData wksRst, vntDataB, Empty End If Set wksRst = Nothing End Sub Private Sub NoMatch(vntData As Variant, vntSheet As Variant, lngLimit As Long) ' 「記号」が片方の倉庫にしか無い場合の処理 Dim wksRst As Worksheet '結果を書き込むシート If Not IsNumeric(vntData(1, 3)) Then Exit Sub End If If vntData(1, 3) < lngLimit Then '雛形2をCopy GetSheet vntSheet(1), vntData, wksRst '倉庫データを転記 PostData wksRst, vntData, Empty Else '雛形3をCopy GetSheet vntSheet(2), vntData, wksRst '倉庫データを転記 PostData wksRst, vntData, Empty End If Set wksRst = Nothing End Sub Private Sub PostData(wksMark As Worksheet, vntData1 As Variant, vntData2 As Variant) If wksMark Is Nothing Then Exit Sub End If With wksMark .Range("E4").Value = Left(vntData1(1, 1), 2) .Range("P4").Value = vntData1(1, 2) .Range("C7").Value = vntData1(1, 1) .Range("K7").Value = vntData1(1, 3) If VarType(vntData2) = vbArray + vbVariant Then .Range("C23").Value = vntData2(1, 1) .Range("K23").Value = vntData2(1, 3) End If End With End Sub Private Function GetBasicData(rngList As Range, _ lngRows As Long, _ lngColumns As Long, _ lngKey As Long, _ vntData As Variant, _ lngIdx() As Long) As Boolean Dim i As Long '基準に就いて With rngList '行数を取得 lngRows = .Offset(Rows.Count - .Row, lngKey).End(xlUp).Row - .Row 'データが無ければFunctionを抜ける(戻り値=False) If lngRows <= 0 Then Exit Function End If '比較用配列に「記号」データを取得 vntData = .Offset(1, lngKey).Resize(lngRows + 1).Value '「記号」データを頭2文字にし、Indexを作成 ReDim lngIdx(1 To lngRows) For i = 1 To lngRows lngIdx(i) = i vntData(i, 1) = Left(vntData(i, 1), 2) Next i 'データを整列 ShellSort vntData, lngIdx 'ダミーデータを挿入 ReDim Preserve lngIdx(1 To lngRows + 1) lngIdx(lngRows + 1) = lngRows + 1 End With GetBasicData = True End Function Private Function DataCompare(vntKeys1 As Variant, lngPos1 As Long, _ vntKeys2 As Variant, lngPos2 As Long) As Long ' データの大小比較 Dim i As Long '比較位置がDataEndを超えた場合 If lngPos1 > UBound(vntKeys1, 1) - 1 Then DataCompare = 1 Exit Function End If If lngPos2 > UBound(vntKeys2, 1) - 1 Then DataCompare = -1 Exit Function End If 'Keyが一致した場合 If vntKeys1(lngPos1, 1) = vntKeys2(lngPos2, 1) Then '戻り値の値として、「等しい」を返す DataCompare = 0 Else 'vntKeys1の値が、vntKeys2の値因り小さい場合 If vntKeys1(lngPos1, 1) < vntKeys2(lngPos2, 1) Then '戻り値の値として、「小さい」を返す DataCompare = -1 Else '戻り値の値として、「大きい」を返す DataCompare = 1 End If End If End Function Private Sub ShellSort(vntList As Variant, _ lngIndex() As Long, _ Optional lngKey As Long = 1) Dim i As Long Dim j As Long Dim lngGap As Long Dim lngTmp As Long Dim lngTop As Long Dim lngEnd As Long Dim blnCompare As Boolean lngTop = LBound(lngIndex, 1) lngEnd = UBound(lngIndex, 1) lngGap = 1 Do While lngGap < (lngEnd - lngTop + 1) ¥ 3 lngGap = 3 * lngGap + 1 Loop Do Until lngGap <= 0 For i = lngGap + lngTop To lngEnd For j = i To lngGap + lngTop Step -lngGap If vntList(lngIndex(j - lngGap), lngKey) > vntList(lngIndex(j), lngKey) Then lngTmp = lngIndex(j - lngGap) lngIndex(j - lngGap) = lngIndex(j) lngIndex(j) = lngTmp Else Exit For End If Next j Next i lngGap = lngGap ¥ 3 Loop End Sub (Bun) ---- Bun様ありがとうございます。 シート名も実際のものに変えて実行しましたが、 ・【】というしーとが(26)まで作られる（中身は空、全て雛形2をコピーされたもの） ・下記の条件が無視される ○雛形1を使う場合 ・両方にデータがあり、両方とも数量が2000未満の場合 ○雛形2を使う場合 ・両方にデータがあり、片方が2000以上で、もう片方が2000未満の場合の2000未満の商品 ・片方だけにデータがあり、数量が2000未満の場合 ○雛形3を使う場合 ・両方にデータがあり、両方が2000以上の場合 ・両方にデータがあり、片方が2000以上の場合の2000以上の商品 ・片方にデータがあり、数量が2000以上の場合 雛形2であるものに雛形1が使われたり、その逆になったり、倉庫【】というシートができたりします。 どういう条件で上の状況になっているか分かりません… （きゃとら） ---- 問題が起きるサンプルデータを載せておくと良いと思いますよ。 ＞・【】というしーとが(26)まで作られる これは、元データを確認してみて下さい。 表と表の間に、空行が合計で26行分有りませんか? ＞倉庫【】というシートができたりします。 これは、ご説明で ＞＞あとすみません、最初のデータシートは、ところどころ、途中の行に2行目と同じ見出しが入ります。 と言う事でしたが、実際は1行目も入っていませんか? サンプルデータを作り直してもう一度投稿されるのが良いのではないでしょうか。 投稿者の多くは、説明されているサンプルデータで動きを確認して居ます。 きゃとらさんも、最初にご自身が載せて居られるデータで 確認してみられたらどうですか? (HANA) ---- HANA様ありがとうございます。 以前HANA様に教わりましたコードを、元データのレイアウトが変わったので改訂しながら作ってます… サンプルデータを再度書きなおしました A B C D E F G 1 倉庫A 倉庫B 2 記号 品名 数量 記号 品名 数量 3 Ap_A りんご 150 Ap_B りんご 300 4 Or_A みかん 20 Gp_B ぶどう 400 5 Gp_A ぶどう 2500 Sb_B いちご 100 6 Sb_A いちご 200 Ml_B メロン 2400 7 Ml_A メロン 2100 Lm_B レモン 2600 8 Bb_B ブルーベリー 500 9 Cr_B さくらんぼ 100 ・・・・ 20 倉庫A 倉庫B ←この部分は日によって行が変わる 21 記号 品名 数量 記号 品名 数量 ←この部分は日によって行が変わる 22 Bn_A バナナ 2550 Tm_B トマト 200 23 Tm_A トマト 2100 ・・・・ 40 倉庫A 倉庫B ←この部分は日によって行が変わる 41 記号 品名 数量 記号 品名 数量 ←この部分は日によって行が変わる 42 Cb_A きゅうり 10 ・・・・ 45 倉庫A 倉庫B ←この部分は日によって行が変わる 46 記号 品名 数量 記号 品名 数量 ←この部分は日によって行が変わる 47 Te_A 紅茶 2000 Oj_B オレンジジュース 10 48 Gt_B 緑茶 2600 このようになっています。 これで比較をしたいのですが、現状では上記のようなエラーになります。 >表と表の間に、空行が合計で26行分有りませんか? 今は12行空白があります。 （きゃとら） ---- >・【】というしーとが(26)まで作られる（中身は空、全て雛形2をコピーされたもの） 上記がどう言う状態で作成されるかと言いますと 雛形シートをCopyし、シート名を変更する時、記号列のデータが""の時に起こります 詰まり、倉庫A、倉庫Bのデータを1行分づつ取得している部分で「記号」列に""が在る場合この様に成ります 当方の考えている列位置と実際の列位置が違う様な気がします? また、「倉庫【】」と言うシートが出来ると言う事は、本来「記号」と言う列見出しの下からデータを 見て行く様にコードは作られているのにデータ2つ上を見ています? 行位置も私が思っている物と違っている様です? 上記の様子から、データが最初に質問をされた時に書かれている状態と違う様な気がします? 先ず、為しとして、新規のBookを作りSheet1に最初にUpされたデータを全く同じに再現して下さい Sheet1 A B C D E F G 1 倉庫A 倉庫B 2 記号 品名 数量 記号 品名 数量 3 Ap_A りんご 150 Ap_B りんご 300 4 Or_A みかん 20 Gp_B ぶどう 400 5 Gp_A ぶどう 2500 Sb_B いちご 100 6 Sb_A いちご 200 Ml_B メロン 2400 7 Ml_A メロン 2100 Lm_B レモン 2600 次に、VBEの画面から新規の標準モジュールを追加して最後にUpしたコードを全てCopyして貼り付けます 次に、VBE画面で「デバッグ」→「VBEprojectのコンパイル」を選択してBookを適当な名前を付けて保存します 次に、Excelの画面に戻し、マクロを実行して下さい これでどう成りますか? (Bun) ---- サンプルデータが全く違うのですね! 此れでは動作の保障は出来ません もう一度、確認して見ます (Bun) ---- 此れで、多分大丈夫だと思いますが? 以下の★印の2箇所を変更して下さい Private Sub Match(vntDataA As Variant, vntDataB As Variant, _ vntSheet As Variant, lngLimit As Long) ' 「記号」がMatchした場合の処理 Dim wksRst As Worksheet '結果を書き込むシート ' If Not IsNumeric(vntDataA(1, 3)) Then If IsEmpty(vntDataA(1, 3)) Or Not IsNumeric(vntDataA(1, 3)) Then '★変更 Exit Sub End If '両方とも数量が2000未満の場合 Private Sub NoMatch(vntData As Variant, vntSheet As Variant, lngLimit As Long) ' 「記号」が片方の倉庫にしか無い場合の処理 Dim wksRst As Worksheet '結果を書き込むシート ' If Not IsNumeric(vntData(1, 3)) Then If IsEmpty(vntData(1, 3)) Or Not IsNumeric(vntData(1, 3)) Then '★変更 Exit Sub End If If vntData(1, 3) < lngLimit Then 尚、出力シートの条件は、私としては合っていると思いますが? 条件を勘違いしてるかも解りませんので善く確認して下さい (Bun) PS:次回からサンプルデータは正確にお願いします ---- Bun様ありがとうございます。 できました。 >次回からサンプルデータは正確にお願いします 申し訳ございませんでした。気をつけます。 （きゃとら）... - https://www.excel.studio-kazu.jp/wiki/kazuwiki/201204/20120416110515.txt - [detail] - similar
PREV
NEXT
Powered by Hyper Estraier 1.4.13, with 97065 documents and 608341 words.
訪問者：