Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちら をご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。

  新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム  
9267 / 13644 ﾂﾘｰ ←次へ　｜　前へ→
▼ 【28286】差額チェック Help me!! 05/9/2(金) 8:06 質問[未読]
【28287】Re:差額チェック ちくたく 05/9/2(金) 8:57 発言[未読]
【28289】Re:差額チェック Help me!! 05/9/2(金) 9:28 質問[未読]
【28290】Re:差額チェック だるま 05/9/2(金) 10:25 発言[未読]
【28291】Re:差額チェック Help me!! 05/9/2(金) 10:42 質問[未読]
【28295】Re:差額チェック だるま 05/9/2(金) 11:32 発言[未読]
【28297】Re:差額チェック Help me!! 05/9/2(金) 11:47 質問[未読]
【28298】Re:差額チェック こたつねこ 05/9/2(金) 11:56 発言[未読]
【28299】Re:差額チェック こたつねこ 05/9/2(金) 12:00 発言[未読]
【28318】Re:差額チェック Help me!! 05/9/2(金) 13:59 質問[未読]
【28320】Re:差額チェック Help me!! 05/9/2(金) 14:06 発言[未読]
【28322】Re:差額チェック こたつねこ 05/9/2(金) 14:29 発言[未読]
【28324】Re:差額チェック Help me!! 05/9/2(金) 14:36 質問[未読]
【28330】Re:差額チェック こたつねこ 05/9/2(金) 15:30 回答[未読]
【28300】Re:差額チェック ちくたく 05/9/2(金) 12:04 回答[未読]
【28301】Re:差額チェック m2m10 05/9/2(金) 12:12 回答[未読]
【28307】Re:差額チェック Help me!! 05/9/2(金) 13:00 質問[未読]
【28309】Re:差額チェック m2m10 05/9/2(金) 13:06 回答[未読]
【28312】Re:差額チェック Help me!! 05/9/2(金) 13:26 質問[未読]
【28315】Re:差額チェック m2m10 05/9/2(金) 13:42 発言[未読]
【28317】Re:差額チェック m2m10 05/9/2(金) 13:56 発言[未読]
【28308】Re:差額チェック りん 05/9/2(金) 13:03 回答[未読]
【28310】Re:差額チェック Help me!! 05/9/2(金) 13:13 質問[未読]
【28321】Re:差額チェック りん 05/9/2(金) 14:20 回答[未読]
【28325】Re:差額チェック Help me!! 05/9/2(金) 14:42 質問[未読]
【28326】Re:差額チェック m2m10 05/9/2(金) 15:11 発言[未読]
【28332】助けてくださった皆様へ！ Help me!! 05/9/2(金) 16:06 お礼[未読]
【28286】差額チェック
質問  Help me!!  - 05/9/2(金) 8:06 -
引用なし
パスワード
   2つのシートAとシートBがあります。
それぞれのシートには管理番号と金額が載っています。
その管理番号を基準にして、金額の差額を見たいのです。
しかし、シートAにはあってシートBには無い管理番号やシートBにはあってシートAには無い管理番号があります。

わかりにくいので、表を書きます。

シートA　　　　　　　　　　　　　シートB
管理番号　　　　金額　　　　　　　管理番号　　　　　　金額
　　1　　　　　　500　　　　　　　　　1　　　　　　　　500
　　2　　　　　　300　　　　　　　　　2　　　　　　　　200
　　3　　　　　　400　　　　　　　　　4　　　　　　　　500
　　5　　　　　　500　　　　　　　　　5　　　　　　　　500
　　8　　　　　　700　　　　　　　　　9　　　　　　　　600


のようにシートAには管理番号の「４」が存在しません。
また、管理番号の「２」の金額がシートAとBでは異なります。


このように異なったデータのリスト（管理番号と差額）が一覧で別シートに作られるような仕組みは作りたいのですが、まったくわかりません。

ちなみに、管理番号は「D171931」のような7桁のローマ字が頭にある数列です。


このようなデーターが10000件あります。
今は一つ一つ目で見てやっています。
2日も掛かります。

どうにかなりませんか？
お助けください。
よろしくお願い致します。
【28287】Re:差額チェック
発言  ちくたく  - 05/9/2(金) 8:57 -
引用なし
パスワード
   おはようございます。
例えば、処理的には早くありませんが、
下のようなコードでの処理が想定できます。

下のコードはSheet1とSheet2の、
A列に管理番号が、
B列に金額が入っていると想定して、
インデックスナンバは同じなのに、値が違ったときに、
その行に色塗りをしています。

多分、VBAじゃなくても、エクセルの関数で、処理できるのでしょうが、
私は詳しくありませんので、識者の登場をお待ちします。

Sub ふたつのシートの差分()
　　
　　Dim i As Integer, j As Integer
　　Dim wS1 As Worksheet, wS2 As Worksheet
　　
　　Set wS1 = Worksheets("Sheet1")
　　Set wS2 = Worksheets("Sheet2")
　　
　　For i = 1 To 100
　　　　For j = 1 To 100
　　　　　　If wS1.Range("A" & i).Value = wS2.Range("A" & j).Value Then
　　　　　　　　wS1.Range("C" & i).Value = wS2.Range("B" & j).Value
　　　　　　　　If wS1.Range("B" & i).Value <> wS1.Range("C" & i).Value Then
　　　　　　　　　　wS1.Rows(i).Interior.ColorIndex = 6
　　　　　　　　　　Exit For
　　　　　　　　End If
　　　　　　End If
　　　　Next j
　　Next i
　　
End Sub
【28289】Re:差額チェック
質問  Help me!!  - 05/9/2(金) 9:28 -
引用なし
パスワード
   ちくたくさん！
迅速な回答ありがとうございます。

でもこれって、「sheet1 にはあって、sheet2には無い」と「sheet2にはあって、sheet1には無い」　という管理番号の差分はチェックされていませんよね？

処理してみましたけど、そんなに時間かからなかったですよ！！
すごいですね！！

でも上記の件の対応は無理でしょうか？

よろしくお願いします。
【28290】Re:差額チェック
発言  だるま WEB  - 05/9/2(金) 10:25 -
引用なし
パスワード
   こんにちは

シートAとシートBで異なっているデータは大量にあるのでしょうか。
もし、異なっている部分がそんなに多くなく、その部分がわかるだけでも良いという
ことでしたら出来合いのこんなソフトもあります。^d^

不一致抽出
http://www.vector.co.jp/soft/win95/business/se372889.html

作業列に、管理番号 & "," & 金額　を作れば比較できます。
【28291】Re:差額チェック
質問  Help me!!  - 05/9/2(金) 10:42 -
引用なし
パスワード
   だるま さん

こんにちわ。
使ってみましたが、うまく実行されません。

どうやって使えばいいのでしょう？


>
>シートAとシートBで異なっているデータは大量にあるのでしょうか。
>もし、異なっている部分がそんなに多くなく、その部分がわかるだけでも良いという
>ことでしたら出来合いのこんなソフトもあります。^d^
>
>不一致抽出
>http://www.vector.co.jp/soft/win95/business/se372889.html
>
>作業列に、管理番号 & "," & 金額　を作れば比較できます。
【28295】Re:差額チェック
発言  だるま WEB  - 05/9/2(金) 11:32 -
引用なし
パスワード
   ここで私のソフトの使い方うんぬんの話は、掲示板の趣旨にそぐわないので止めま
しょう。

それよりまず、
>異なっている部分がそんなに多くなく、その部分がわかるだけでも良い
のでしょうか。

それと、出力の具体的なイメージを示せばもっと回答が付くのではないかと思い
ますが。^d^
【28297】Re:差額チェック
質問  Help me!!  - 05/9/2(金) 11:47 -
引用なし
パスワード
   異なっている部分は200〜300件です。
ですが、一番の悩み所は双方向にチェックしないといけないところです。

シート１にはあって、シート２には無い
シート２にはあって、シート１には無い

このデータを吸い出して、別シートに転記するのがまず第一の壁です。。。

その後、双方向に該当があるデータに関しては金額の項目の差異を出す。


どなたかお助けください・・・

もう頭が痛くなってきました・・・
【28298】Re:差額チェック
発言  こたつねこ  - 05/9/2(金) 11:56 -
引用なし
パスワード
   ▼Help me!! さん：
こんにちは

>異なっている部分は200〜300件です。
>ですが、一番の悩み所は双方向にチェックしないといけないところです。
>
一覧にするのであればシート１のデータを基準として全て取出し
シート２のデータを比較して、あればそのデータに金額を追加、
無ければ新たにデータを追加でいいのではないでしょうか？

とりあえず作ってみました、もっと簡単になりそうですが･･･
間違ってたらごめんなさい

Private Sub tekitou()
　　Const strSheet1 As String = "Sheet1"
　　Const strSheet2 As String = "Sheet2"
　　Const strSheet3 As String = "Sheet3"
　　
　　Dim WK() As Variant
　　Dim WD() As Variant
　　Dim RE As Integer
　　Dim i As Integer
　　Dim j　　As Integer
　　Dim Flg As Boolean
　　
　　With Sheets(strSheet1)
　　　　RE = .Range("a65536").End(xlUp).Row
　　　　ReDim WK(1 To 3, 1 To RE) As Variant
　　　　j = 1
　　　　For i = 1 To RE
　　　　　　WK(1, j) = .Cells(i, 1)
　　　　　　WK(2, j) = .Cells(i, 2)
　　　　　　j = j + 1
　　　　Next i
　　End With
　　
　　With Sheets(strSheet2)
　　　　RE = .Range("a65536").End(xlUp).Row
　　　　For i = 1 To RE
　　　　　　Flg = False
　　　　　　For j = 1 To UBound(WK, 2)
　　　　　　　　If WK(1, j) = .Cells(i, 1) Then
　　　　　　　　　　WK(3, j) = .Cells(i, 2)
　　　　　　　　　　Flg = True
　　　　　　　　　　Exit For
　　　　　　　　End If
　　　　　　Next j
　　　　　　If Flg = False Then
　　　　　　　　ReDim Preserve WK(1 To 3, 1 To UBound(WK, 2) + 1) As Variant
　　　　　　　　WK(1, UBound(WK, 2)) = .Cells(i, 1)
　　　　　　　　WK(3, UBound(WK, 2)) = .Cells(i, 2)
　　　　　　End If
　　　　Next i
　　End With
　　
　　ReDim WD(1 To UBound(WK, 2), 1 To 3) As Variant
　　
　　For i = 1 To UBound(WK, 2)
　　　　For j = 1 To 3
　　　　　　WD(i, j) = WK(j, i)
　　　　Next j
　　Next i
　　
　　WD(1, 2) = strSheet1 & vbCrLf & WD(1, 2)
　　WD(1, 3) = strSheet2 & vbCrLf & WD(1, 3)
　　
　　With Sheets(Sheet3)
　　　　.UsedRange.Clear
　　　　.Range("A1:A" & UBound(WD, 1)).Numberformat = "@"
　　　　.Range("A1:C" & UBound(WD, 1)) = WD
　　　　.Range("D1") = "差額"
　　　　.Range("D2:D" & UBound(WD, 1)).FormulaR1C1 = "=rc[-2]-rc[-1]"
　　End With
End Sub
【28299】Re:差額チェック
発言  こたつねこ  - 05/9/2(金) 12:00 -
引用なし
パスワード
   ごめんなさい、修正です。
タイプミスです申し訳ない･･･

>　　With Sheets(Sheet3)
With Sheets(strSheet3)

>　　　　.UsedRange.Clear
>　　　　.Range("A1:A" & UBound(WD, 1)).Numberformat = "@"
>　　　　.Range("A1:C" & UBound(WD, 1)) = WD
>　　　　.Range("D1") = "差額"
>　　　　.Range("D2:D" & UBound(WD, 1)).FormulaR1C1 = "=rc[-2]-rc[-1]"
>　　End With
>End Sub
【28300】Re:差額チェック
回答  ちくたく  - 05/9/2(金) 12:04 -
引用なし
パスワード
   こんにちは。
もうすでに回答もでているようですが。
Sheet1とSheet2をチェックし、Sheet3に書き出し。
その後、Sheet3をチェック、B列（Sheet1の金額）とC列（Sheet2の金額）
が違ったら、色塗り。

Sub ひとつのシートにまとめて処理()
　　
　　Dim i As Integer, j As Integer
　　Dim wS1 As Worksheet, wS2 As Worksheet, wS3 As Worksheet
　　Dim firVal As Integer, secVal As Integer
　　
　　Set wS1 = Worksheets("Sheet1")
　　Set wS2 = Worksheets("Sheet2")
　　Set wS3 = Worksheets("Sheet3")
　　　　
　　For i = 1 To 100
　　　　firVal = wS1.Range("A" & i).Value
　　　　secVal = wS1.Range("B" & i).Value
　　　　
　　　　If firVal <> 0 Then
　　　　　　wS3.Cells(firVal, 1).Value = firVal
　　　　　　wS3.Cells(firVal, 2).Value = secVal
　　　　End If
　　　　
　　　　firVal = wS2.Range("A" & i).Value
　　　　secVal = wS2.Range("B" & i).Value
　　　　
　　　　If firVal <> 0 Then
　　　　　　wS3.Cells(firVal, 1).Value = firVal
　　　　　　wS3.Cells(firVal, 3).Value = secVal
　　　　End If
　　Next i
　　
　　For i = 1 To 100
　　　　If wS3.Range("B" & i).Value <> wS3.Range("C" & i).Value Then wS3.Rows(i).Interior.ColorIndex = 6
　　Next
End Sub
【28301】Re:差額チェック
回答  m2m10  - 05/9/2(金) 12:12 -
引用なし
パスワード
   私の一つ
'Microsoft DAO X.X Object Library 参照設定が必要です。
　'http://www.accessclub.jp/actips/tips_32.htm
　'シートA シートB Sheet3 が必要。
　
Sub DAO_001()
　'*********************************************************************
　'　　ExcelのシートとシートのSQL　DAO 接続
　'*********************************************************************

　　Dim db As DAO.Database
　　Dim rs As DAO.Recordset
　　
　　Dim strSQL As String
　
　　Set db = OpenDatabase(ThisWorkbook.FullName, False, False, "EXCEL 8.0;HDR=YES;")
　
　
　　　 strSQL = "SELECT シートA$.管理番号, シートA$.金額, シートB$.金額　" & _
　　　　　　 "FROM [シートA$] INNER JOIN [シートB$] ON シートA$.管理番号 = シートB$.管理番号 " & _
　　　　　　 "WHERE シートA$.金額<>[シートB$.金額];"
　　
　
　　Set rs = db.OpenRecordset(strSQL, dbOpenDynaset)

　　 Sheets("Sheet3").Range("A2").CopyFromRecordset rs
　　 rs.Close


　　　strSQL = " SELECT シートA$.管理番号, シートA$.金額, シートB$.金額　" & _
　　　　　　　 "FROM [シートA$] LEFT JOIN [シートB$] ON シートA$.管理番号 = シートB$.管理番号 " & _
　　　　　　　 "WHERE シートB$.金額 Is Null;"

　　Set rs = db.OpenRecordset(strSQL, dbOpenDynaset)

　　 Sheets("Sheet3").Range("F2").CopyFromRecordset rs
　　 rs.Close

　　　strSQL = " SELECT シートB$.管理番号, シートB$.金額, シートA$.金額　" & _
　　　　　　　 "FROM [シートA$] RIGHT JOIN [シートB$] ON シートA$.管理番号 = シートB$.管理番号 " & _
　　　　　　　 "WHERE シートA$.金額 Is Null;"

　　Set rs = db.OpenRecordset(strSQL, dbOpenDynaset)

　　 Sheets("Sheet3").Range("J2").CopyFromRecordset rs


　　rs.Close
　　db.Close

End Sub
【28307】Re:差額チェック
質問  Help me!!  - 05/9/2(金) 13:00 -
引用なし
パスワード
   m2m10 さん

エラーが出ます。

クエリ式'シートB$金額　FROM[シートA] INNER JOIN [シートB＄] ON シートA$　管理番号=シートB$管理番号　WHERE シートA$金額　＜＞[シートB$金額]'の構成文エラー：演算子がありません。
と出ます。

デバックすると


　　Set rs = db.OpenRecordset(strSQL, dbOpenDynaset)

が黄色くなっています。


どうしていいのかまったくわかりません。

よろしくお願いします。


>私の一つ
>'Microsoft DAO X.X Object Library 参照設定が必要です。
>　'http://www.accessclub.jp/actips/tips_32.htm
>　'シートA シートB Sheet3 が必要。
>　
>Sub DAO_001()
>　'*********************************************************************
>　'　　ExcelのシートとシートのSQL　DAO 接続
>　'*********************************************************************
>
>　　Dim db As DAO.Database
>　　Dim rs As DAO.Recordset
>　　
>　　Dim strSQL As String
>　
>　　Set db = OpenDatabase(ThisWorkbook.FullName, False, False, "EXCEL 8.0;HDR=YES;")
>　
>　
>　　　 strSQL = "SELECT シートA$.管理番号, シートA$.金額, シートB$.金額　" & _
>　　　　　　 "FROM [シートA$] INNER JOIN [シートB$] ON シートA$.管理番号 = シートB$.管理番号 " & _
>　　　　　　 "WHERE シートA$.金額<>[シートB$.金額];"
>　　
>　
>　　Set rs = db.OpenRecordset(strSQL, dbOpenDynaset)
>
>　　 Sheets("Sheet3").Range("A2").CopyFromRecordset rs
>　　 rs.Close
>
>
>　　　strSQL = " SELECT シートA$.管理番号, シートA$.金額, シートB$.金額　" & _
>　　　　　　　 "FROM [シートA$] LEFT JOIN [シートB$] ON シートA$.管理番号 = シートB$.管理番号 " & _
>　　　　　　　 "WHERE シートB$.金額 Is Null;"
>
>　　Set rs = db.OpenRecordset(strSQL, dbOpenDynaset)
>
>　　 Sheets("Sheet3").Range("F2").CopyFromRecordset rs
>　　 rs.Close
>
>　　　strSQL = " SELECT シートB$.管理番号, シートB$.金額, シートA$.金額　" & _
>　　　　　　　 "FROM [シートA$] RIGHT JOIN [シートB$] ON シートA$.管理番号 = シートB$.管理番号 " & _
>　　　　　　　 "WHERE シートA$.金額 Is Null;"
>
>　　Set rs = db.OpenRecordset(strSQL, dbOpenDynaset)
>
>　　 Sheets("Sheet3").Range("J2").CopyFromRecordset rs
>
>
>　　rs.Close
>　　db.Close
>
>End Sub
【28308】Re:差額チェック
回答  りん E-MAIL  - 05/9/2(金) 13:03 -
引用なし
パスワード
   それぞれのシートの
１行目が見出し、２行目からデータ
Ａ列がコード、Ｂ列が金額として。

Sub test()
　 Dim wb As Workbook, ws1 As Worksheet
　 Dim r1 As Range, r2 As Range, Rpos1&, Rpos2&, Rpos&
　
　 Set wb = ActiveWorkbook
　 wb.Worksheets("A").Copy '新しいシートが新しいブックにできる
　 Set ws1 = Application.ActiveSheet
　 '
　 With wb.Worksheets("B")
　　　Set r1 = .Range(.Range("A2"), .Range("A2").End(xlDown)).EntireRow
　 End With
　 '
　 With ws1
　　　Rpos1& = .Range("A65536").End(xlUp).Row
　　　.Cells(2, 4).Value = 100001
　　　.Range(.Cells(2, 4), .Cells(Rpos1&, 4)).DataSeries Rowcol:=xlColumns, Type:=xlLinear, Step:=1, Trend:=False
　　　'
　　　'下に追加
　　　r1.Copy Destination:=.Cells(Rpos1& + 1, 1)
　　　Rpos2& = .Range("A65536").End(xlUp).Row
　　　.Cells(Rpos1& + 1, 4).Value = 200001
　　　.Range(.Cells(Rpos1& + 1, 4), .Cells(Rpos2&, 4)).DataSeries Rowcol:=xlColumns, Type:=xlLinear, Step:=1, Trend:=False
　　　
　　　'戻す為のソートキーをDに付与
　　　'並べ替え
　　　.Range(.Cells(2, 1), .Cells(Rpos2&, 4)).Sort key1:=.Cells(2, 1), Order1:=xlAscending, _
　　　　　　　　　　　　　　　　　　　　　　　　　key2:=.Cells(2, 4), Order2:=xlAscending, _
　　　　　　　　　　　　　　　　　　　　　　　　　Header:=xlNo, SortMethod:=xlStroke
　
　　　Set r2 = .Cells(Rpos2& + 1, 4) '無条件で削除してもよい行
　　　Rpos& = Rpos2&
　　　'
　　　Do
　　　　 If .Cells(Rpos&, 1).Value = .Cells(Rpos& - 1, 1).Value Then
　　　　　　If .Cells(Rpos&, 2).Value = .Cells(Rpos& - 1, 2).Value Then
　　　　　　　 '削除対象
　　　　　　　 Set r2 = Application.Union(r2, .Cells(Rpos&, 4), .Cells(Rpos& - 1, 4))
　　　　　　Else
　　　　　　　 'データを繰り上げて1つ削除
　　　　　　　 .Cells(Rpos, 2).Cut .Cells(Rpos - 1, 3)
　　　　　　　 Set r2 = Application.Union(r2, .Cells(Rpos&, 4))
　　　　　　End If
　　　　　　Rpos& = Rpos& - 1
　　　　 Else
　　　　　　If .Cells(Rpos, 4).Value > 200000 Then _
　　　　　　　 .Cells(Rpos, 2).Cut .Cells(Rpos, 3)
　　　　 End If
　　　　 Rpos& = Rpos& - 1
　　　Loop While Rpos& > 2
　　　r2.EntireRow.Delete
　　　'ソートして元のならびに戻す
　　　Rpos2& = .Range("A65536").End(xlUp).Row
　　　.Range(.Cells(2, 1), .Cells(Rpos2&, 4)).Sort key1:=.Cells(2, 4), Order1:=xlAscending
　　　'ソートキー削除
　　　.Columns(4).Delete
　　　.Range("B1").Value = "金額A"
　　　.Range("C1").Value = "金額B"
　 End With
　 '
　 Set r1 = Nothing: Set r2 = Nothing
　 Set ws1 = Nothing: Set wb = Nothing
End Sub
【28309】Re:差額チェック
回答  m2m10  - 05/9/2(金) 13:06 -
引用なし
パスワード
   >エラーが出ます。
>
>クエリ式'シートB$金額　FROM[シートA] INNER JOIN [シートB＄] ON シートA$　管理番号=シートB$管理番号　WHERE シートA$金額　＜＞[シートB$金額]'の構成文エラー：演算子がありません。
>と出ます。
>

シート名が合ってないと思います

当初
　シートA 　シートB 　と有りましたので

　シートA 　シートB　Sheet3　で作成しました。
　
【28310】Re:差額チェック
質問  Help me!!  - 05/9/2(金) 13:13 -
引用なし
パスワード
   りん さん

ありがとうございます。
かなり近くなってきました。

ですが、新しくできたシートの項目で金額B　がおかしいです。

どこをどういう風になおしたらよいのかわかりません。

ちなみに、シートAとシートBのA列に管理番号、B列に金額がはいっており、C列以降は他のデータも入っていますが問題ありませんよね？

よろしくお願いします。


>それぞれのシートの
>１行目が見出し、２行目からデータ
>Ａ列がコード、Ｂ列が金額として。
>
>Sub test()
>　 Dim wb As Workbook, ws1 As Worksheet
>　 Dim r1 As Range, r2 As Range, Rpos1&, Rpos2&, Rpos&
>　
>　 Set wb = ActiveWorkbook
>　 wb.Worksheets("A").Copy '新しいシートが新しいブックにできる
>　 Set ws1 = Application.ActiveSheet
>　 '
>　 With wb.Worksheets("B")
>　　　Set r1 = .Range(.Range("A2"), .Range("A2").End(xlDown)).EntireRow
>　 End With
>　 '
>　 With ws1
>　　　Rpos1& = .Range("A65536").End(xlUp).Row
>　　　.Cells(2, 4).Value = 100001
>　　　.Range(.Cells(2, 4), .Cells(Rpos1&, 4)).DataSeries Rowcol:=xlColumns, Type:=xlLinear, Step:=1, Trend:=False
>　　　'
>　　　'下に追加
>　　　r1.Copy Destination:=.Cells(Rpos1& + 1, 1)
>　　　Rpos2& = .Range("A65536").End(xlUp).Row
>　　　.Cells(Rpos1& + 1, 4).Value = 200001
>　　　.Range(.Cells(Rpos1& + 1, 4), .Cells(Rpos2&, 4)).DataSeries Rowcol:=xlColumns, Type:=xlLinear, Step:=1, Trend:=False
>　　　
>　　　'戻す為のソートキーをDに付与
>　　　'並べ替え
>　　　.Range(.Cells(2, 1), .Cells(Rpos2&, 4)).Sort key1:=.Cells(2, 1), Order1:=xlAscending, _
>　　　　　　　　　　　　　　　　　　　　　　　　　key2:=.Cells(2, 4), Order2:=xlAscending, _
>　　　　　　　　　　　　　　　　　　　　　　　　　Header:=xlNo, SortMethod:=xlStroke
>　
>　　　Set r2 = .Cells(Rpos2& + 1, 4) '無条件で削除してもよい行
>　　　Rpos& = Rpos2&
>　　　'
>　　　Do
>　　　　 If .Cells(Rpos&, 1).Value = .Cells(Rpos& - 1, 1).Value Then
>　　　　　　If .Cells(Rpos&, 2).Value = .Cells(Rpos& - 1, 2).Value Then
>　　　　　　　 '削除対象
>　　　　　　　 Set r2 = Application.Union(r2, .Cells(Rpos&, 4), .Cells(Rpos& - 1, 4))
>　　　　　　Else
>　　　　　　　 'データを繰り上げて1つ削除
>　　　　　　　 .Cells(Rpos, 2).Cut .Cells(Rpos - 1, 3)
>　　　　　　　 Set r2 = Application.Union(r2, .Cells(Rpos&, 4))
>　　　　　　End If
>　　　　　　Rpos& = Rpos& - 1
>　　　　 Else
>　　　　　　If .Cells(Rpos, 4).Value > 200000 Then _
>　　　　　　　 .Cells(Rpos, 2).Cut .Cells(Rpos, 3)
>　　　　 End If
>　　　　 Rpos& = Rpos& - 1
>　　　Loop While Rpos& > 2
>　　　r2.EntireRow.Delete
>　　　'ソートして元のならびに戻す
>　　　Rpos2& = .Range("A65536").End(xlUp).Row
>　　　.Range(.Cells(2, 1), .Cells(Rpos2&, 4)).Sort key1:=.Cells(2, 4), Order1:=xlAscending
>　　　'ソートキー削除
>　　　.Columns(4).Delete
>　　　.Range("B1").Value = "金額A"
>　　　.Range("C1").Value = "金額B"
>　 End With
>　 '
>　 Set r1 = Nothing: Set r2 = Nothing
>　 Set ws1 = Nothing: Set wb = Nothing
>End Sub
【28312】Re:差額チェック
質問  Help me!!  - 05/9/2(金) 13:26 -
引用なし
パスワード
   m2m10 さん

迅速な回答ありがとうございます。


ですが、だめです。
シート名をそのままVBAからコピッてもだめでした。

ひょっとして、管理番号と金額以外にも項目があるからですか？
【28315】Re:差額チェック
発言  m2m10  - 05/9/2(金) 13:42 -
引用なし
パスワード
   >ひょっとして、管理番号と金額以外にも項目があるからですか？

関係有りません、私の環境では動作してます。

　項目名にブランクが有るとか？

　参照設定はしましたよね。

　項目名の上のセルに文字が有ったら駄目です。
【28317】Re:差額チェック
発言  m2m10  - 05/9/2(金) 13:56 -
引用なし
パスワード
   後、同じ項目名が有ると駄目です。
【28318】Re:差額チェック
質問  Help me!!  - 05/9/2(金) 13:59 -
引用なし
パスワード
   こたつねこ さん

すごいです！
できました！！
もう一つわがまま聞いてもらえないでしょうか？

sheet1とsheet2にはそれぞれ、管理番号と金額以外の項目もあります。

それも最後の一覧に載せたいのです。

厳密にいうと

sheet1 には　管理番号と金額以外に１７項目存在します。（合計１９項目）
sheet2 には　管理番号と金額以外に8項目存在します。（合計１０項目）

このデータも載せれないでしょうか？

よろしくお願いします。

本当に助かります。
【28320】Re:差額チェック
発言  Help me!!  - 05/9/2(金) 14:06 -
引用なし
パスワード
   こたつねこ さん

ごめんなさい。
sheet2の項目は管理番号・金額以外で9個です。

よろしくお願いします。
【28321】Re:差額チェック
回答  りん E-MAIL  - 05/9/2(金) 14:20 -
引用なし
パスワード
   Help me!! さん、こんにちわ。
一部修正。

Sub test()
　 Dim wb As Workbook, ws1 As Worksheet
　 Dim r1 As Range, r2 As Range, r3 As Range, Rpos1&, Rpos2&, Rpos&
　
　 Set wb = ActiveWorkbook
　 Set ws1 = Application.Workbooks.Add.Worksheets(1) '新しいブック
　 '
　 With wb.Worksheets("A")
　　　Rpos1& = .Range("A65536").End(xlUp).Row
　　　Set r1 = .Range(.Cells(2, 1), .Cells(Rpos1&, 2))
　 End With
　 With wb.Worksheets("B")
　　　Rpos2& = .Range("A65536").End(xlUp).Row
　　　Set r2 = .Range(.Cells(2, 1), .Cells(Rpos2&, 2))
　 End With
　 '
　 With ws1
　　　'
　　　.Range("A1").Value = "管理番号"
　　　.Range("B1").Value = "金額A"
　　　.Range("C1").Value = "金額B"
　　　'値だけ貼る
　　　r1.Copy: .Cells(2, 1).PasteSpecial xlValue
　　　.Cells(2, 4).Value = 100001
　　　.Range(.Cells(2, 4), .Cells(Rpos1&, 4)).DataSeries Rowcol:=xlColumns, Type:=xlLinear, Step:=1, Trend:=False
　　　'
　　　'下に追加
　　　r2.Copy: .Cells(Rpos1& + 1, 1).PasteSpecial xlValue
　　　Rpos2& = .Range("A65536").End(xlUp).Row '位置再計算
　　　.Cells(Rpos1& + 1, 4).Value = 200001
　　　.Range(.Cells(Rpos1& + 1, 4), .Cells(Rpos2&, 4)).DataSeries Rowcol:=xlColumns, Type:=xlLinear, Step:=1, Trend:=False
　
　　　'戻す為のソートキーをDに付与
　　　'並べ替え
　　　.Range(.Cells(2, 1), .Cells(Rpos2&, 4)).Sort key1:=.Cells(2, 1), Order1:=xlAscending, _
　　　　　　　　　　　　　　　　　　　　　　　　　key2:=.Cells(2, 4), Order2:=xlAscending, _
　　　　　　　　　　　　　　　　　　　　　　　　　Header:=xlNo, SortMethod:=xlStroke
　
　　　'
　　　Set r3 = .Cells(Rpos2& + 1, 4) '無条件で削除してもよい行
　　　Rpos& = Rpos2&
　　　'
　　　Do
　　　　 If .Cells(Rpos&, 1).Value = .Cells(Rpos& - 1, 1).Value Then
　　　　　　If .Cells(Rpos&, 2).Value = .Cells(Rpos& - 1, 2).Value Then
　　　　　　　 '削除対象
　　　　　　　 Set r3 = Application.Union(r3, .Cells(Rpos&, 4), .Cells(Rpos& - 1, 4))
　　　　　　Else
　　　　　　　 'データを繰り上げて1つ削除
　　　　　　　 .Cells(Rpos, 2).Cut .Cells(Rpos - 1, 3)
　　　　　　　 Set r3 = Application.Union(r3, .Cells(Rpos&, 4))
　　　　　　End If
　　　　　　Rpos& = Rpos& - 1
　　　　 Else
　　　　　　If .Cells(Rpos, 4).Value > 200000 Then _
　　　　　　　 .Cells(Rpos, 2).Cut .Cells(Rpos, 3)
　　　　 End If
　　　　 Rpos& = Rpos& - 1
　　　Loop While Rpos& > 2
　　　r3.EntireRow.Delete
　　　'ソートして元のならびに戻す
　　　Rpos2& = .Range("A65536").End(xlUp).Row
　　　.Range(.Cells(2, 1), .Cells(Rpos2&, 4)).Sort key1:=.Cells(2, 4), Order1:=xlAscending
　　　'ソートキー削除
　　　.Columns(4).Delete
　　　.Range("A1").Select
　 End With
　 '
　 Set r1 = Nothing: Set r2 = Nothing: Set r3 = Nothing
　 Set ws1 = Nothing: Set wb = Nothing
End Sub
今は時間がとれないので、わからないところがあれば解説はまた後ほど。
【28322】Re:差額チェック
発言  こたつねこ  - 05/9/2(金) 14:29 -
引用なし
パスワード
   ▼Help me!! さん：
こんにちは

どの様な一覧にしたいのかイメージがつかめないので
Sheet1とSheet2と一覧表の具体的なサンプルを上げて
頂けないでしょうか？

他の方のコードもかなり上がってきているようですし、
実際のシートの構成によっては他の方のコードを使用
したほうが良い場合も多々あると思いますので。
【28324】Re:差額チェック
質問  Help me!!  - 05/9/2(金) 14:36 -
引用なし
パスワード
   回答ありがとうございます！

Sheet1には
管理番号,仕入金額（金額）,手配ＮＯ１,仕入摘要,仕入日,仕入先名称,品名,品名摘要１,品名摘要２,仕入数量,仕入単価,仕入消費税額,仕入 本部コード,仕入 部コード,仕入 課コード,仕入計上区分,変更担当者,入力担当者

という項目があります。

sheet2には
管理番号,発注金額（金額）,種類,品名,出荷数,発注単価,備考,配送区分,組織名称,手配ＮＯ１,発注納期

という項目があります。


完成された表のイメージは、

管理番号,金額の差異,手配ＮＯ１,仕入摘要,仕入日,仕入先名称,品名,品名摘要１,品名摘要２,仕入数量,仕入単価,仕入消費税額,仕入 本部コード,仕入 部コード,仕入 課コード,仕入計上区分,変更担当者,入力担当者,種類,品名,出荷数,発注単価,備考,配送区分,組織名称,手配ＮＯ１,発注納期

という項目がそのままコピーされていればOKです。
【28325】Re:差額チェック
質問  Help me!!  - 05/9/2(金) 14:42 -
引用なし
パスワード
   ありがとうございます！！

さくさく動きました！！

そこで、もう一つお願いしてもよろしいですか？
お願いします！！

シートAには
管理番号,仕入金額（金額）,手配ＮＯ１,仕入摘要,仕入日,仕入先名称,品名,品名摘要１,品名摘要２,仕入数量,仕入単価,仕入消費税額,仕入 本部コード,仕入 部コード,仕入 課コード,仕入計上区分,変更担当者,入力担当者

という項目があります。

シートBには
管理番号,発注金額（金額）,種類,品名,出荷数,発注単価,備考,配送区分,組織名称,手配ＮＯ１,発注納期

という項目があります。

管理番号で値を拾ってくるときについでにこれらの項目すべても付け足せないでしょうか？？

完成された表のイメージ（項目名を左から順に）は、
管理番号　　　　金額A　　　　金額B

管理番号　,　金額A　,　金額B　,　金額Aと金額Bの差　,手配ＮＯ１　,仕入摘要　,　仕入日　,　仕入先名称　,　品名　,　品名摘要１　,　品名摘要２　,　仕入数量　,　仕入単価　,　仕入消費税額　,　仕入本部コード　,　仕入 部コード　,　仕入 課コード　,　仕入計上区分　,　変更担当者　,　入力担当者　,　 種類　,　品名　,　出荷数　,発注単価　,備考　,配送区分　,　組織名称　,　手配ＮＯ１　,　発注納期


という風にできないでしょうか？
お時間が無いところ作っていただき本当に感謝しております。

それと、解説の方も今後の私の成長のためにもお時間がある時で結構ですのでぜひお願いしたいと思います。


よろしくお願いします。
【28326】Re:差額チェック
発言  m2m10  - 05/9/2(金) 15:11 -
引用なし
パスワード
   当初
>シートA　　　　　　　　　　　　　シートB
>管理番号　　　　金額　　　　　　　管理番号　　　　　　金額
>　　1　　　　　　500　　　　　　　　　1　　　　　　　　500
>　　2　　　　　　300　　　　　　　　　2　　　　　　　　200
>　　3　　　　　　400　　　　　　　　　4　　　　　　　　500
>　　5　　　　　　500　　　　　　　　　5　　　　　　　　500
>　　8　　　　　　700　　　　　　　　　9　　　　　　　　600

今回
>
>シートAには
>管理番号,仕入金額（金額）,手配ＮＯ１,仕入摘要,仕入日,仕入先名称,品名,品名摘要１,品名摘要２,仕入数量,仕入単価,仕入消費税額,仕入 本部コード,仕入 部コード,仕入 課コード,仕入計上区分,変更担当者,入力担当者
>
>という項目があります。
>
>シートBには
>管理番号,発注金額（金額）,種類,品名,出荷数,発注単価,備考,配送区分,組織名称,手配ＮＯ１,発注納期
>
>という項目があります。
>

　　やはり、項目名が違うので、ｓｑｌで動かなかったと思います。

　シートの項目　仕入金額（金額）と　発注金額（金額）を　金額　に
　修正をすれば　良いと思います。
【28330】Re:差額チェック
回答  こたつねこ  - 05/9/2(金) 15:30 -
引用なし
パスワード
   ▼Help me!! さん：
こんにちは

とりあえず追加してみました。
が、りんさんのコードのほうがコメントもきちんと
書かれていてやすいと思います。

だったらコメントくらい書けと言われそうですが･･･
今回もコメントなしです、ごめんなさい。

Private Sub 差額一覧表作成()
　　Const strSheet1 As String = "Sheet1"
　　Const strSheet2 As String = "Sheet2"
　　Const strSheet3 As String = "Sheet3"
　　
　　Dim WK() As Variant
　　Dim WD() As Variant
　　Dim RE As Integer
　　Dim i As Integer
　　Dim j　　As Integer
　　Dim k As Integer
　　Dim Flg As Boolean
　　
　　With Sheets(strSheet1)
　　　　RE = .Range("A65536").End(xlUp).Row
　　　　ReDim WK(1 To 27, 1 To RE) As Variant
　　　　j = 1
　　　　For i = 1 To RE
　　　　　　For j = 1 To 27
　　　　　　　　WK(j, i) = .Cells(i, j).Value
　　　　　　Next j
　　　　Next i
　　End With
　　
　　With Sheets(strSheet2)
　　　　RE = .Range("A65536").End(xlUp).Row
　　　　For i = 1 To RE
　　　　　　Flg = False
　　　　　　For j = 1 To UBound(WK, 2)
　　　　　　　　If WK(1, j) = .Cells(i, 1) Then
　　　　　　　　　　If IsNumeric(.Cells(i, 2).Value) Then
　　　　　　　　　　　　WK(2, j) = WK(2, j) - .Cells(i, 2).Value
　　　　　　　　　　End If
　　　　　　　　　　For k = 3 To 11
　　　　　　　　　　　　WK(16 + k, j) = .Cells(i, k).Value
　　　　　　　　　　Next k
　　　　　　　　　　Flg = True
　　　　　　　　　　Exit For
　　　　　　　　End If
　　　　　　Next j

　　　　　　If Flg = False Then
　　　　　　　　ReDim Preserve WK(1 To 27, 1 To UBound(WK, 2) + 1) As Variant
　　　　　　　　WK(1, UBound(WK, 2)) = .Cells(i, 1).Value
　　　　　　　　WK(2, UBound(WK, 2)) = -.Cells(i, 2).Value
　　　　　　　　For k = 3 To 11
　　　　　　　　　　WK(16 + k, UBound(WK, 2)) = .Cells(i, k).Value
　　　　　　　　Next k
　　　　　　End If
　　　　Next i
　　End With
　　
　　ReDim WD(1 To UBound(WK, 2), 1 To 27) As Variant
　　
　　For i = 1 To UBound(WK, 2)
　　　　For j = 1 To 27
　　　　　　WD(i, j) = WK(j, i)
　　　　Next
　　Next
　　
　　WD(1, 2) = "金額の差異"
　　
　　With Sheets(strSheet3)
　　　　.UsedRange.Clear
　　　　.Range("a2:a" & UBound(WD, 1)).NumberFormat = "@"
　　　　.Range("c2:d" & UBound(WD, 1)).NumberFormat = "@"
　　　　.Range("e2:e" & UBound(WD, 1)).NumberFormat = "gee/mm/dd"
　　　　.Range("f2:i" & UBound(WD, 1)).NumberFormat = "@"
　　　　.Range("m2:t" & UBound(WD, 1)).NumberFormat = "@"
　　　　.Range("w2:z" & UBound(WD, 1)).NumberFormat = "@"
　　　　.Range("aa2:aa" & UBound(WD, 1)).NumberFormat = "gee/mm/dd"
　　　　.Range("A1:AA" & UBound(WD, 1)) = WD
　　End With
End Sub
【28332】助けてくださった皆様へ！
お礼  Help me!!  - 05/9/2(金) 16:06 -
引用なし
パスワード
   皆様、本当にありがとうございました。
そして、ご迷惑おかけしました。

無事に目的のコードを作りだすことができました。

まだまだ勉強不足な為、またここへ来て質問するかも知れません。

その時はまた暖かくアドバイスのほどよろしくお願い致します。


今日は本当にありがとうございました。

本当に感謝の気持ちでいっぱいです。
  新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム  
9267 / 13644 ﾂﾘｰ ←次へ　｜　前へ→
ページ：  ┃  記事番号：
2610219
(SS)C-BOARD v3.8 is Free