0

タイトルで述べたように、あるシートから別のシートにデータをコピーする必要があります。両方のシートに同じデータ (同じ順序ではない) があります。2 番目のシートの対応する行が変更されたため、1 番目のシートのデータを更新したいと考えています。たとえば、最初のシートに次のようなものがあります。

A   B           C 
1   one         1.1
2   two         1.2
3   three       1.3
4   one + two   2.3
5   one + three  ??

そして2番目のもので：

A   B          C 
1   one        1.1
2   two        1.2
3   three      1.3

2番目に書いたように、更新ボタンは変更された行を更新し、「1 + 3」の形式の行があるかどうかを見つけようとします。そのため、「one」と「three」のデータもその行にコピーされます。将来、別のマルチネーム行 (:one + four または two + three など) が追加された場合、ボタンは同じことを行います。

このコードでシート内のすべてのデータを更新しようとしました:

 Private Sub CommandButton2_Click()

 Dim salesData As Range, targetRng As Range
 Dim e As Integer
 Set salesData = Worksheets("sheet1").Range("A2:C" & Range("A1").End(xlDown).Row)

 If Worksheets("sheet2").Range("B2") = vbNullString Then
      Set targetRng = Worksheets("sheet2").Range("A2") 'If no data in SalesDB start in row 2
 Else
      Set targetRng = Worksheets("sheet2").Range("A1").End(xlDown).Offset(1, 0) 'If data already in SalesDB, find next free row
 End If
 salesData.Copy Destination:=targetRng
 End Sub

しかし、それは私にとっては役に立ちません: 1 すべてのデータをコピーします (時間がかかり、"Worksheets("sheet2").Range("B2") = vbNullString" のため、残りの空の行にデータを追加します。それらを更新しないでください）

2-列 B の値をチェックして、更新する「one + three」という名前のフィールドがあるかどうかを確認できません。

最後に、忘れないでください: 私は VBA と Excel プログラミングの初心者です!! 前もって感謝します

更新 1::

 Private Sub CommandButton5_Click()
 'here the beginning of  of your solution
 'after and instead of this line:
 'salesData.Copy Destination:=targetRng
 'try this... but carefully for the first time :)
  Dim salesData As Range, targetRng As Range
 Dim e As Integer
 Set salesData = Worksheets("sheet1").Range("A2:C" & Range("A1").End(xlDown).Row)

  ' Worksheets("Sheet2").Select

 If Worksheets("sheet2").Range("B2") = vbNullString Then
      Set targetRng = Worksheets("sheet2").Range("A2") 'If no data in SalesDB start in        row 2
 Else
      Set targetRng = Worksheets("sheet2").Range("A1").End(xlDown).Offset(1, 0) 'If   data already in SalesDB, find next free row
 End If

 targetRna.Columns(3).ClearContents

Dim dataItem
Dim Found As Range
Dim rngStart As Range
Set rngStart = targetRna.Cells(1, 1)
Dim strFirstAddress As String
For Each dataItem In salesData.Columns(2).Cells

Set Found = targetRna.Find(dataItem.Value, rngStart, xlValues, xlPart)

If Not Found Is Nothing Then
    strFirstAddress = Found.Address

    Do
        If dataItem.Value = Found.Value Then
            Found.Offset(0, 1) = dataItem.Offset(0, 1)
        Else
            Found.Offset(0, 1) = Found.Offset(0, 1) + dataItem.Offset(0, 1)
        End If
        Set rngStart = Found

    Set Found = targetRna.Find(dataItem.Value, rngStart, xlValues, xlPart)

    If Found Is Nothing Then
        Exit Do
    ElseIf Found.Address = strFirstAddress Then
        Exit Do
    End If


    Loop
End If

Next
End Sub

Edit2:: () 画像を表示するためにアドレスにスペースを空けてください ![ボタンはこのシートに影響します][1] [1]: http://i.stack.imgur.com/ zSg1p.png

![更新ボタンはこちらになります][2] [2]: http://i.stack.imgur.com/ sNiVK.png

4

1 に答える 1

0

あなたの代わりに：

salesData.Copy Destination:=targetRng

次のコードを使用してみてください。

Private Sub CommandButton2_Click()
'here the beginning of  of your solution
'after and instead of this line:
'salesData.Copy Destination:=targetRng
'try this... but carefully for the first time :)

targetRna.Columns(3).ClearContents

Dim dataItem
Dim Found As Range
Dim rngStart As Range
Set rngStart = targetRna.Cells(1, 1)
    Dim strFirstAddress As String
For Each dataItem In salesData.Columns(2).Cells

    Set Found = targetRna.Find(dataItem.Value, rngStart, xlValues, xlPart)

    If Not Found Is Nothing Then
        strFirstAddress = Found.Address

        Do
            If dataItem.Value = Found.Value Then
                Found.Offset(0, 1) = dataItem.Offset(0, 1)
            Else
                Found.Offset(0, 1) = Found.Offset(0, 1) + dataItem.Offset(0, 1)
            End If
            Set rngStart = Found

        Set Found = targetRna.Find(dataItem.Value, rngStart, xlValues, xlPart)

        If Found Is Nothing Then
            Exit Do
        ElseIf Found.Address = strFirstAddress Then
            Exit Do
        End If


        Loop
    End If

Next
End Sub

編集済み: もう一度言いますが、あなたのコンセプトのどの部分も見逃さなかったことを願っています。コードがシート2からシート1にコピーされている間に、シート1からシート2へのコピーについて書いているため、わかりません。ここに画像の説明を入力ここに画像の説明を入力

そして完全なコード:

Private Sub CommandButton2_Click()
    Dim salesData As Range, targetRng As Range
    Dim e As Integer
    Set salesData = Worksheets("sheet2").Range("A1:C" & Range("A1").End(xlDown).Row)

   If Worksheets("sheet1").Range("B2") = vbNullString Then
   Set targetRng = Worksheets("sheet1").Range("A2") 'If no data in SalesDB start in        row 2
   salesData.Copy Destination:=targetRng
   Exit Sub
   Else
  'if data already exists than set range to search in
  Set targetRng = Worksheets("sheet1").Range("A1").CurrentRegion
  End If

  targetRng.Columns(3).ClearContents

   Dim boFound As Boolean
   Dim dataItem
   Dim Found As Range
   Dim rngStart As Range
   Set rngStart = targetRng.Cells(1, 1)
   Dim strFirstAddress As String
   For Each dataItem In salesData.Columns(2).Cells

          Set Found = targetRng.Find(dataItem.Value, rngStart, xlValues, xlPart)

          If Not Found Is Nothing Then
          strFirstAddress = Found.Address
          boFound = True
             Do 
               If dataItem.Value = Found.Value Then
                  Found.Offset(0, 1) = dataItem.Offset(0, 1)
               Else
                  Found.Offset(0, 1) = Found.Offset(0, 1) + dataItem.Offset(0, 1)
               End If
          Set rngStart = Found

         Set Found = targetRng.Find(dataItem.Value, rngStart, xlValues, xlPart)

         If Found Is Nothing Then
              Exit Do
         ElseIf Found.Address = strFirstAddress Then
             Exit Do
         End If
         Loop
   End If

   If Not boFound Then
          'if not found then copy into first free row
         dataItem.Offset(0, -1).Resize(1, 3).Copy Worksheets("sheet1").Range("A1").End(xlDown).Offset(1, 0)
   End If

   boFound = False

   Next


   End Sub
于 2013-04-04T13:47:20.000 に答える