Excel VBA質問箱 IV

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

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


9269 / 13646 ツリー ←次へ | 前へ→

【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には管理番号の「4」が存在しません。
また、管理番号の「2」の金額がシート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件です。
ですが、一番の悩み所は双方向にチェックしないといけないところです。

シート1にはあって、シート2には無い
シート2にはあって、シート1には無い

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

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


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

もう頭が痛くなってきました・・・

【28298】Re:差額チェック
発言  こたつねこ  - 05/9/2(金) 11:56 -

引用なし
パスワード
   ▼Help me!! さん:
こんにちは

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

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

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 -

引用なし
パスワード
   それぞれのシートの
1行目が見出し、2行目からデータ
A列がコード、B列が金額として。

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列以降は他のデータも入っていますが問題ありませんよね?

よろしくお願いします。


>それぞれのシートの
>1行目が見出し、2行目からデータ
>A列がコード、B列が金額として。
>
>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 には 管理番号と金額以外に17項目存在します。(合計19項目)
sheet2 には 管理番号と金額以外に8項目存在します。(合計10項目)

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

よろしくお願いします。

本当に助かります。

【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には
管理番号,仕入金額(金額),手配NO1,仕入摘要,仕入日,仕入先名称,品名,品名摘要1,品名摘要2,仕入数量,仕入単価,仕入消費税額,仕入 本部コード,仕入 部コード,仕入 課コード,仕入計上区分,変更担当者,入力担当者

という項目があります。

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

という項目があります。


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

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

という項目がそのままコピーされていればOKです。

【28325】Re:差額チェック
質問  Help me!!  - 05/9/2(金) 14:42 -

引用なし
パスワード
   ありがとうございます!!

さくさく動きました!!

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

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

という項目があります。

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

という項目があります。

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

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

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


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

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


よろしくお願いします。

【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には
>管理番号,仕入金額(金額),手配NO1,仕入摘要,仕入日,仕入先名称,品名,品名摘要1,品名摘要2,仕入数量,仕入単価,仕入消費税額,仕入 本部コード,仕入 部コード,仕入 課コード,仕入計上区分,変更担当者,入力担当者
>
>という項目があります。
>
>シートBには
>管理番号,発注金額(金額),種類,品名,出荷数,発注単価,備考,配送区分,組織名称,手配NO1,発注納期
>
>という項目があります。
>

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

 シートの項目 仕入金額(金額)と 発注金額(金額)を 金額 に
 修正をすれば 良いと思います。

【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 -

引用なし
パスワード
   皆様、本当にありがとうございました。
そして、ご迷惑おかけしました。

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

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

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


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

本当に感謝の気持ちでいっぱいです。

9269 / 13646 ツリー ←次へ | 前へ→
ページ:  ┃  記事番号:
2610219
(SS)C-BOARD v3.8 is Free