0

シート 2 には、列 A に一連のルールがあります。

列 A の例では、各行に複数のコードがあり、行 B から H には、そのコードに対応するデータに基づくデータがあります。

シート 1 にコードの 1 つを配置し、このコードが列 A のコードと一致する場合、VBA がシート 2 から行 B:H を転送できるようにしたいと考えています。

これが私がこれまでに持っているプログラムです。行を転送しますが、正しい行は転送しません。

    Dim i As Integer
    Dim x As Integer
    Dim row As Integer
    Dim oldRow As Integer
    Dim found As Boolean
    Dim ws1 As Worksheet
    Dim ws2 As Worksheet
    Set ws1 = Worksheets("Sheet1")
    Set ws2 = Worksheets("Sheet2")
    Dim rng As Range, cell As Range, rng2 As Range, cell2 As Range

Set rng2 = ws2.Range("A1:A212")
Set rng = ws1.Range("A1:A212")

row = 1
oldRow = 1


For Each cell In rng
    row = row + 1

    For Each cell2 In rng2
        oldRow = oldRow + 1

        If cell.Value = cell2.Value Then
        row = row - 1
            ws1.Cells(row, 2) = ws2.Cells(oldRow, 2)
            ws1.Cells(row, 3) = ws2.Cells(oldRow, 3)
            ws1.Cells(row, 4) = ws2.Cells(oldRow, 4)
            ws1.Cells(row, 5) = ws2.Cells(oldRow, 5)
            ws1.Cells(row, 6) = ws2.Cells(oldRow, 6)
            ws1.Cells(row, 7) = ws2.Cells(oldRow, 7)
            ws1.Cells(row, 8) = ws2.Cells(oldRow, 8)
            found = True
        End If



    Next
    found = False
    oldRow = 1

Next

End Sub

助けてくれてありがとう、ありがとう。

4

4 に答える 4

0

これは VBA である必要がありますか? VLOOKUPまたは、ワークシート関数を使用できますか? それは事実上、物事の音から達成しようとしていることだからです。

VLOOKUPを使用してVBAで使用することもできますApplication.WorksheetFunction.VLookup

あなたの問題は、インクリメントrowしoldRowていて、ループの最後ではなく最初にあることが原因である可能性があります。したがって、最初に実行すると、値は1ではなく2になります。また、おそらく実行する必要はありませんrow = row - 1。紛らわしい。

于 2013-10-10T20:14:41.043 に答える
0

次のようにコードを変更します。

Sub test()
    Dim i As Integer
    Dim n As Integer
    Dim ws1 As Worksheet
    Dim ws2 As Worksheet
    Set ws1 = Worksheets("Sheet1")
    Set ws2 = Worksheets("Sheet2")

    'Cycles through the codes in sheet 1
    For i = 2 To ws1.Cells(ws1.Rows.Count, 1).End(xlUp).row Step 1
        For n = 2 To ws2.Cells(ws2.Rows.Count, 1).End(xlUp).row Step 1
            If ws1.Cells(i, 1).Value = ws2.Cells(n, 1).Value Then
                ws1.Cells(i, 2).Value = ws2.Cells(n, 2).Value
                ws1.Cells(i, 3).Value = ws2.Cells(n, 3).Value
                ws1.Cells(i, 4).Value = ws2.Cells(n, 4).Value
                ws1.Cells(i, 5).Value = ws2.Cells(n, 5).Value
                ws1.Cells(i, 6).Value = ws2.Cells(n, 6).Value
                ws1.Cells(i, 7).Value = ws2.Cells(n, 7).Value
                ws1.Cells(i, 8).Value = ws2.Cells(n, 8).Value
            End If
        Next n
    Next i
End Sub
于 2013-10-10T20:25:31.530 に答える
0

これは式で行うことができます。「Sheet1」セル B1 で上下にコピー:

=IF(COUNTIF(Sheet2!$A:$A,$A1)=0,"",VLOOKUP($A1,Sheet2!$A:$H,COLUMN(B1),0))

マクロでなければならない場合は、次のようなものが機能するはずです。

Sub tgr()

    Dim ws1 As Worksheet
    Dim ws2 As Worksheet
    Dim rngFound As Range
    Dim arrCodes As Variant
    Dim arrResults As Variant
    Dim varCode As Variant
    Dim ResultIndex As Long
    Dim cIndex As Long

    Set ws1 = ActiveWorkbook.Sheets("Sheet1")
    Set ws2 = ActiveWorkbook.Sheets("Sheet2")

    arrCodes = ws1.Range("A1", ws1.Cells(Rows.Count, "A").End(xlUp)).Value
    If Not IsArray(arrCodes) Then Exit Sub  'No data
    ReDim arrResults(1 To UBound(arrCodes, 1), 1 To 7)

    For Each varCode In arrCodes
        ResultIndex = ResultIndex + 1
        Set rngFound = ws2.Columns("A").Find(varCode, , xlValues, xlWhole)
        If Not rngFound Is Nothing Then
            For cIndex = 1 To UBound(arrResults, 2)
                arrResults(ResultIndex, cIndex) = WorksheetFunction.VLookup(varCode, ws2.Range("A:H"), cIndex + 1, False)
            Next cIndex
        End If
    Next varCode

    ws1.Range("B1").Resize(UBound(arrResults, 1), UBound(arrResults, 2)).Value = arrResults

End Sub
于 2013-10-10T20:17:30.797 に答える
0

未テスト:

Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim rng As Range, f As Range, rng2 As Range
Dim c as range, cell as Range


Set ws1 = Worksheets("Sheet1")
Set ws2 = Worksheets("Sheet2")
Set rng = ws1.Range("A1:A212")
Set rng2 = ws2.Range("A1:A212")

row = 1
oldRow = 1


For Each cell In rng.Cells
    if len(cell.value)>0 Then
        Set f = rng2.Find(cell.Value, lookin:=xlvalues, lookat:=xlWhole)
        if not f is nothing then
            cell.offset(0,1).Resize(1,7).Value = _
               f.offset(0,1).resize(1,7).Value
        end if   
    end if   
Next cell
于 2013-10-10T20:12:34.777 に答える