CODEWITHSUNDEEP
arraysexcelvba
Nick Morgan
Nick Morgan

Reputation: 166

Copying information from arrays

I have this code that compares two lists, and it works well, but I need to copy the information associated with certain cells (they're to the right of each cell in the sheet the array is populated from) to another sheet. Is this possible?

Here's my code:

Option Explicit
Sub RemoveUnwantedText(ByRef theArray As Variant)

Dim theValue As String
Dim i As Long
Dim indexOfComma As Integer
    ' array is created from single-column range of cells
    ' and so has 2 dimensions
    For i = LBound(theArray, 1) To UBound(theArray, 1)
        theValue = CStr(theArray(i, 1))
        indexOfComma = InStr(1, theValue, ",")
        If indexOfComma > 0 Then
            theValue = Trim(Left(theValue, indexOfComma - 1))
        End If
        theArray(i, 1) = theValue
    Next i

End Sub

Private Sub cmdCompare2to1_Click()



Dim sheet1 As Worksheet, sheet2 As Worksheet, sheet3 As Worksheet
Dim lngLastR As Long, lngCnt As Long
Dim var1 As Variant, var2 As Variant, x
Dim rng1 As Range, rng2 As Range


Set sheet1 = Worksheets(1)
Set sheet2 = Worksheets(2)
Set sheet3 = Worksheets(3) ' assumes sheet3 is a blank sheet in your workbook

Application.ScreenUpdating = False

'let's get everything all set up
'sheet3 column headers
sheet3.Range("A1:B1").Value = Array("in1Not2", "in2Not1")

'sheet1 range and fill array
With sheet1

    lngLastR = .Range("A" & .Rows.Count).End(xlUp).Row

    Set rng1 = .Range("A1:A" & lngLastR)
    var1 = rng1

End With

'sheet2 range and fill array
With sheet2

    lngLastR = .Range("A" & .Rows.Count).End(xlUp).Row

    Set rng2 = .Range("A1:A" & lngLastR)
    var2 = rng2

End With

RemoveUnwantedText var1
RemoveUnwantedText var2

'first check sheet1 against sheet2
On Error GoTo NoMatch1
For lngCnt = 1 To UBound(var1)

    x = Application.WorksheetFunction.Match(var1(lngCnt, 1), rng2, False)

Next


'now check sheet2 against sheet1
On Error GoTo NoMatch2
For lngCnt = 1 To UBound(var2)

    x = Application.WorksheetFunction.Match(var2(lngCnt, 1), rng1, False)

Next

On Error GoTo 0
Application.ScreenUpdating = True
Exit Sub

NoMatch1:
    sheet3.Range("A" & sheet3.Rows.Count).End(xlUp).Offset(1) = var1(lngCnt, 1)
    Resume Next


NoMatch2:
    sheet3.Range("B" & sheet3.Rows.Count).End(xlUp).Offset(1) = var2(lngCnt, 1)
    Resume Next


End Sub

EDIT

okay I adapted the answer below like this for my data:

NoMatch1: sheet3.Range("A" & sheet3.Rows.Count).End(xlUp).Offset(1) = var1(lngCnt, 1) 'Reference Cell in Sheet1 column B using lngCnt in the loop and put in column C sheet4.Range("A" & sheet3.Rows.Count).End(xlUp).Offset(1) = sheet2.Cells(lngCnt, 1) sheet4.Range("B" & sheet3.Rows.Count).End(xlUp).Offset(1) = sheet2.Cells(lngCnt, 2) sheet4.Range("C" & sheet3.Rows.Count).End(xlUp).Offset(1) = sheet2.Cells(lngCnt, 3) sheet4.Range("D" & sheet3.Rows.Count).End(xlUp).Offset(1) = sheet2.Cells(lngCnt, 4) sheet4.Range("E" & sheet3.Rows.Count).End(xlUp).Offset(1) = sheet2.Cells(lngCnt, 5) sheet4.Range("F" & sheet3.Rows.Count).End(xlUp).Offset(1) = sheet2.Cells(lngCnt, 6) sheet4.Range("G" & sheet3.Rows.Count).End(xlUp).Offset(1) = sheet2.Cells(lngCnt, 7) sheet4.Range("H" & sheet3.Rows.Count).End(xlUp).Offset(1) = sheet2.Cells(lngCnt, 8) Resume Next

However... my situation is this.

I have list 1, which is a bunch of company names. I have list 2, which is my entire file of all our clients and addresses.

My thinking has been -> compare lists, get the names of the companies that are on both lists, get the address information from list 2 ONLY for the company names that are on both lists.

I think this is close... I just can't quite wrap my head around how to do this.

Upvotes: 2

Views: 79

Answers (1)

user1274820
user1274820

Reputation: 8144

As I said in my comment:

Yes, reference the cell using your location in the array loop.

If you're at var1(lngCnt, 1), then you can use something like

sheet3.Range("C" & sheet3.Rows.Count).End(xlUp).Offset(1) = sheet1.Cells(lngCnt, 2)

In this modification, I put the values to the right of the ones copied:

NoMatch1:
    sheet3.Range("A" & sheet3.Rows.Count).End(xlUp).Offset(1) = var1(lngCnt, 1)
    'Reference Cell in Sheet1 column B using lngCnt in the loop and put in column C
    sheet3.Range("C" & sheet3.Rows.Count).End(xlUp).Offset(1) = sheet1.Cells(lngCnt, 2)
    Resume Next


NoMatch2:
    sheet3.Range("B" & sheet3.Rows.Count).End(xlUp).Offset(1) = var2(lngCnt, 1)
    'Reference Cell in Sheet2 column B using lngCnt in the loop and put in column D
    sheet3.Range("D" & sheet3.Rows.Count).End(xlUp).Offset(1) = sheet2.Cells(lngCnt, 2)
    Resume Next

Results:

Results

Edit:

Sub GetAddressesOnBothLists()
Dim c                             'c will be our iterator
Dim Finder As Range               'Finder will search our range
Dim SearchRangeS1, SearchRangeS2  'These are the ranges to search

'Set the search ranges for Sheet1 and Sheet2
'Here we search column A, but you can use any range you want
Set SearchRangeS1 = Sheet1.Range("A1:A" & Sheet1.Cells(Rows.Count, 1).End(xlUp).Row)
Set SearchRangeS2 = Sheet2.Range("A1:A" & Sheet2.Cells(Rows.Count, 1).End(xlUp).Row)

'Clear Sheet3 for output
Sheet3.Cells.Clear
Sheet3.Range("A1") = "Company Name"
Sheet3.Range("B1") = "Company Address"

'For Each Cell in SearchRangeS1
For Each c In SearchRangeS1
    Set Finder = Nothing
    'Search for the value in SearchRangeS2
    Set Finder = SearchRangeS2.Find(c.Value, LookAt:=xlWhole)
    'If we find the value
    If Not Finder Is Nothing Then
        With Sheet3.Range("A" & Sheet3.Cells(Rows.Count, 1).End(xlUp).Row + 1)
            'Output the found value to Sheet3 column A
            .Value = Finder.Value
            'Output the address from Sheet2 in the Cell next to it (B)
            .Offset(0, 1).Value = Finder.Offset(0, 1)
        End With
    End If
Next c
End Sub

Results using the above code:

Results2

Edit2:

This will return duplicate results on Sheet2.

Note that if there are duplicates on Sheet1, it will return all duplicates on Sheet2 again.

Sub GetAddressesOnBothLists()
Dim c
Dim Finder As Range
Dim DuplicateFinder 'This will store the address of our first Find
Dim SearchRangeS1, SearchRangeS2

Set SearchRangeS1 = Sheet1.Range("A1:A" & Sheet1.Cells(Rows.Count, 1).End(xlUp).Row)
Set SearchRangeS2 = Sheet2.Range("A1:A" & Sheet2.Cells(Rows.Count, 1).End(xlUp).Row)

Sheet3.Cells.Clear
Sheet3.Range("A1") = "Company Name"
Sheet3.Range("B1") = "Company Address"
For Each c In SearchRangeS1
    Set Finder = Nothing
    Set Finder = SearchRangeS2.Find(c.Value, LookAt:=xlWhole)
    If Not Finder Is Nothing Then
        'Store the address of our first find so we know when to stop
        DuplicateFinder = Finder.Address
        Do
            With Sheet3.Range("A" & Sheet3.Cells(Rows.Count, 1).End(xlUp).Row + 1)
                .Value = Finder.Value
                .Offset(0, 1).Resize(, 8).Value = Finder.Offset(0, 1).Resize(, 8).Value
            End With
            'Find the next value
            Set Finder = SearchRangeS2.FindNext(Finder)
        'Continue returning results until none are found or we reach our original
        Loop While Not Finder Is Nothing And DuplicateFinder <> Finder.Address
    End If
Next c
End Sub

If the duplicate value thing is an issue, you can loop through each cell in Sheet2 instead of Sheet1 and search Sheet1 instead - if all you are looking to do is make sure the value exists on Sheet1 before copying the Sheet2 data, you can flip the SearchRanges around and get rid of the loop altogether.

That code is here:

Sub GetAddressesOnBothLists()
Dim c
Dim Finder As Range
Dim SearchRangeS1, SearchRangeS2
Set SearchRangeS1 = Sheet1.Range("A1:A" & Sheet1.Cells(Rows.Count, 1).End(xlUp).Row)
Set SearchRangeS2 = Sheet2.Range("A1:A" & Sheet2.Cells(Rows.Count, 1).End(xlUp).Row)
Sheet3.Cells.Clear
Sheet3.Range("A1") = "Company Name"
Sheet3.Range("B1") = "Company Address"
For Each c In SearchRangeS2
    Set Finder = Nothing
    Set Finder = SearchRangeS1.Find(c.Value, LookAt:=xlWhole)
    If Not Finder Is Nothing Then
        With Sheet3.Range("A" & Sheet3.Cells(Rows.Count, 1).End(xlUp).Row + 1)
            .Value = c
            .Offset(0, 1).Resize(, 8).Value = c.Offset(0, 1).Resize(, 8).Value
        End With
    End If
Next c
End Sub

Upvotes: 2

Related Questions