If cells D3, E3 and F3 through row 22 on sheet1 <> cells A6, B6 and D6 through row 22 sheet2 transpose each range isn't on sheet2

Question

I have put together a VBA that copies from Sheet1 to Sheet2 and sorts by date, and if duplicate exists it stops, but if I add new data to sheet1 it won't copy the new data because it sees the old data first. I need help to expand the current macro to find new data on sheet1 and transpose it to sheet2 and then resort by date each time I click the command button on sheet1. Thank you. This has been a month long process and it's killing me. sheet1 Image and Sheet2 image

Dim i       As Long
Dim j       As Long
Dim lastrow As Long
Dim lastrow2 As Long
Dim FirstCell As Long
Dim lastrow3 As Long
Dim SameCell1 As String
Dim SameCell2 As String
Dim SameCell3 As String
Dim SameCell4 As String
Dim SameCell5 As String
Dim SameCell6 As String
Dim SameCell7 As String
Dim SameCell8 As String
Dim SameCell9 As String
Dim SameCell10 As String
Dim SameCell11 As String

Sheets("sheet2").Activate
With ActiveWorkbook.Worksheets("Sheet2").Sort
    .SetRange Range("A5:Q21")
    .Header = xlGuess
    .MatchCase = False
    .Orientation = xlTopToBottom
    .SortMethod = xlPinYin
    .Apply
End With

lastrow2 = Sheets("sheet2").Range("A" & Rows.Count).End(xlDown).Row
For j = 6 To lastrow2
    SameCell4 = Sheets("Sheet2").Range("A" & j).Value
    SameCell5 = Sheets("Sheet2").Range("B" & j).Value
    SameCell6 = Sheets("Sheet2").Range("C" & j).Value

    lastrow = Sheets("sheet1").Range("F" & Rows.Count).End(xlUp).Row + 1
    FirstCell = Sheets("sheet2").Range("A" & Rows.Count).End(xlUp).Row
    lastrow3 = Sheets("sheet1").Range("f" & Rows.Count).End(xlUp).Row
    For i = 3 To lastrow
        SameCell1 = Sheets("Sheet1").Range("D" & i).Value
        SameCell2 = Sheets("Sheet1").Range("E" & i).Value
        SameCell3 = Sheets("Sheet1").Range("F" & i).Value
        SameCell7 = Sheets("Sheet2").Range("A" & j).Value
        SameCell8 = Sheets("Sheet2").Range("B" & j).Value
        SameCell9 = Sheets("Sheet2").Range("C" & j).Value
        SameCell10 = Sheets("Sheet2").Range("C" & FirstCell).Value
        SameCell11 = Sheets("Sheet1").Range("f" & lastrow3).Value
        Sheets("sheet2").Activate

        If SameCell1 = "" Then
            End
        End If
        If SameCell6 = SameCell3 And SameCell3 = SameCell6 Then
            End
        End If
        If SameCell1 <> SameCell4 And SameCell3 <> SameCell6 Then
            Sheets("sheet1").Activate
            Sheets("sheet1").Range(Cells(i, "D"), Cells(i, "F")).Copy
            Sheets("sheet2").Activate
            Sheets("sheet2").Range("A1").End(xlDown).Offset(1, 0).Select
            ActiveSheet.Paste
            With ActiveWorkbook.Worksheets("Sheet2").Sort
                .SetRange Range("A5:Q21")
                .Header = xlGuess
                .MatchCase = False
                .Orientation = xlTopToBottom
                .SortMethod = xlPinYin
                .Apply
            End With
            Sheets("sheet1").Activate
        End If
    Next i
    Application.CutCopyMode = False
Next j
End Sub

Some notes: This If SameCell6 = SameCell3 And SameCell3 = SameCell6 Then doesn't make sense to check that twice, if the first is true then the second must be true too. Don't use End if you mean Exit Sub. End really ends all VBA activity. But Exit Sub will only exit the current procedure. — Pᴇʜ
Thank you. I have removed that line and took out the End. I assumed that with ever if statement I had to end it. Which now that you've pointed it out, makes complete sense. I'm trying to build info based on below data, so we'll see how it turns out. — Steve Cullen

Kurt VonOhlen Kurt VonOhlen · Accepted Answer · 2018-03-13T15:04:18

I hope this isnt too much for you. Feel free to ask away

One method could be to create a dictionary of the sheet1 values

Dim YourDict As Object
Set YourDict = CreateObject("Scripting.Dictionary")
For i = firstrow To lastrow
On Error Resume Next
YourDict.Add datasheet.Cells(i, YourColumn).Value2, _
datasheet.Cells(i,YourColumn).Value2
Next i

note that datasheet, firstrow, lastrow, and yourcolumn are all variables you have to assign. This dict, with the "On Error Resume Next" will skip over any duplicate entries

Then you could loop through the dictionary like so:

 For Each entry In YourDict
 (do stuff)
 Next entry

It is not clear what kind of condition you want to copy vs. not copy, but it could be something like an if statement

I should probably share my IsInArry function here

Function IsInArray(stringToBeFound As String, arr As Variant) As Boolean
  IsInArray = (UBound(Filter(arr, stringToBeFound)) > -1)
End Function

You can assign ranges to arrays, and then I use this function to see if the range has the value I am looking for.

However you will need to convert a variant array into a string array, which is done as follows

ReDim YourStringArray(YourVariantArray.Count - 1) As String
    j = 0
    For Each itm In YourVariantArray.keys()
        YourStringArray(j) = YourStringArray(itm)
        j = j + 1
    Next itm

Also, here is how I get the last row and column (and first row)

Set datasheet = ActiveSheet ' Or the name of your sheet
'this column always has data in every row
SiteCodeCOL = datasheet.Cells.Find("Site Code").Column
With datasheet
lastrow = .Cells(.Rows.Count, SiteCodeCOL).End(xlUp).Row
firstrow = .Cells(.Rows.Count, SiteCodeCOL).End(xlUp).End(xlUp).Row
lastcol = .Cells(firstrow, .Columns.Count).End(xlToLeft).Column
end with

'---------------------------------------------------------

Dim YourDict As Object, sheet1 as Worksheet, sheet2 as Worksheet
Dim sheet1lastrow As Integer, sheet1firstrow as Integer
Dim sheet2firstrow As Integer, sheet2lastrow as Integer
Dim sheet1lastcol As Integer, sheet2lastcol as Integer
Dim DirArray As Variant 'if you wanted to use an array, like I mentioned above: DirArray = Range("A" & i & ":C" & i).Value2
Set YourDict = CreateObject("Scripting.Dictionary")
Set sheet1 = Worksheets("Sheet1") ' may need to include  
Set sheet2 = Worksheets("Sheet2")
With sheet2.Sort
    .SetRange Range("A5:Q21")
    .Header = xlGuess
    .MatchCase = False
    .Orientation = xlTopToBottom
    .SortMethod = xlPinYin
    .Apply
End With

With sheet1
sheet1lastrow = .Cells(.Rows.Count, 4).End(xlUp).Row ' "d" = 4
sheet1firstrow = .Cells(.Rows.Count, 4).End(xlUp).End(xlUp).Row + 2
sheet1lastcol = .Cells(sheet1firstrow, .Columns.Count).End(xlToLeft).Column
End With

on error resume next
For i = sheet1firstrow To sheet1lastrow
YourDict.Add sheet1.cells(i, 1).value2, sheet1.cells(i, 1).value2 ' you are adding a key value pair here 
YourDict.Add sheet1.cells(i, 2).value2, sheet1.cells(i, 2).value2 '(i,2) means the B column, ith row, if i = 4 it means B4
YourDict.Add sheet1.cells(i, 3).value2, sheet1.cells(i, 3).value2 'value2 is the fastest method, it represents the true value of the cell
next i

i = sheet2firstrow
For Each entry In YourDict
YourDict.Add sheet2.Range("D" & i).Value2, CStr(sheet2.Range("D" & i).Value2)
If Err.Number <> 0 Then 'adding a key already in the dictionary will throw an error
' copy the data here
sheet2.range(cells(i,4),cells(i,6)).copy sheet1.cells(i,4)
Err.Clear
i = i + 1
Next entry
on error goto 0

If cells D3, E3 and F3 through row 22 on sheet1 <> cells A6, B6 and D6 through row 22 sheet2 transpose each range isn't on sheet2

1 Answers