CODEWITHSUNDEEP
excelvba
Clepa
Clepa

Reputation: 13

Excel compare two columns from one sheet copy entire row on match to new sheet

I am looking for VBA code that will do the following:

Here is some pseudocode that may clarify what I'm looking for:

For each cell in columnA
Traverse each cell in columnB
If current cell value in columnA matches current cell value in columnB
Copy the entire row at the current columnB position
If we have traversed the entire columnB and have not found a match
Insert a blank row in sheet2

Here is the best I could come up with, but I am not well-versed in manipulating excel sheets:

Sub rowContent()

Dim isMatch As Boolean
isMatch = False

Dim newSheetPos As Integer
newSheetPos = 1

Dim numRows As Integer
numRows = 591

Dim rowPos As Integer
rowPos = 1

For i = 1 To numRows 'Traverse columnA 
 For j = 1 To numRows 'Traverse columnB
    'Compare contents of cell in columnA to cell in ColumnB
    If Worksheets("Sheet1").Cells(i, 1) = Worksheets("Sheet1").Cells(j, 2) Then
        Worksheets("Sheet1").Cells(i, 1).Copy Worksheets("Sheet2").Cells(newSheetPos, 1)
        newSheetPos = newSheetPos + 1'prepare to copy into next row in Sheet2
        isMatch = True 
    End If

    j = j + 1 'increment j to continue traversing columnB
 Next
 'If we have traverse columnB without finding a match
 If Not (isMatch) Then 
        newSheetPos = newSheetPos + 1 'skip row in Sheet2 if no match was found
 End If
 isMatch = False
Next
End Sub

This code does not currently work.

Many thanks for your kind help.

Upvotes: 1

Views: 5918

Answers (1)

Netloh
Netloh

Reputation: 4378

I have made som changes to your code. This should work as your pseudocode-description:

Sub rowContent()
    Dim ws1 As Worksheet
    Dim ws2 As Worksheet
    Dim i As Long, j As Long
    Dim isMatch As Boolean
    Dim newSheetPos As Integer

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

    'Initial position of first element in sheet2
    newSheetPos = ws2.Cells(ws2.Rows.Count, 1).End(xlUp).Row

    For i = 1 To ws1.Cells(ws1.Rows.Count, 1).End(xlUp).Row
        isMatch = False
        For j = 1 To ws1.Cells(ws1.Rows.Count, 2).End(xlUp).Row
            If ws1.Cells(i, 1).Value = ws1.Cells(j, 2).Value Then
                ws1.Cells(j, 2).EntireRow.Copy ws2.Cells(newSheetPos, 1)
                isMatch = True
                newSheetPos = newSheetPos + 1
            End If
        Next j
        If isMatch = False Then newSheetPos = newSheetPos + 1
    Next i
End Sub

Upvotes: 1

Related Questions