Comparing data and pasting duplicates

Nichole09

Board Regular
Joined
Aug 27, 2016
Messages
132
Hello!!! I am trying to learn to code in vba on my own, but I simply cant achieve what I am wanting to do and need help. Below is my code I am working on. What I want to accomplish, is automatically pull up a worksheet that was saved in the past and compare it to the newest data. After comparing loan number's to see if they are a match, I want to paste certain columns of data in those rows with the duplicates and paste them to a new worksheet in the same workbook saved previously.

So far I am able to pull up the previously saved spreadsheet and compare the duplicates, but I am stuck when it comes to copying and pasting only certain items in those rows. Excuse the messy code below. I was trying to write a pra for loop by myself a the end there, but it is just getting out of hand. (as you can see). I am hoping someone can help me clean this up to work faster, and to properly copy and paste the duplicates. Specifically - if there is a duplicate loan, I want the data from that row (only from columns F-K, and V) to be pasted to the new worksheet with the sheet name of the current date and start pasting this data on row 4 columns A - F and move through the duplicates. I appreciate any help!

VBA Code:
Sub compare()
Dim last As Long
Dim filename As String, myfile As String
Dim strfile As String, dtfile As Date
Dim current As Integer, getweeknumber As Integer
Dim dic As Object, ar As Variant, arr As Variant, var As Variant
Dim v()
Dim i As Long, n As Long, j As Long, x As Long, k As Long, l As Long, t As Long, w As Long
Dim str As String
Dim ws As Worksheet, wbk1 As Workbook, ws3 As Workbook, ws1 As Worksheet, ws2 As Worksheet, ws4 As Worksheet
Dim wb, wb1 As Workbook
Dim var1array, var2array
Dim blnmatch As Boolean
Dim lrow As Long
Dim shp As Shape
Dim pt As PivotTable


Dim wbk As Variant, filename1 As String

Set ws1 = Workbooks("Review").Sheets("Ops")
Set wb = Workbooks("LO Review")
Set ws2 = Workbooks("LO Review").Sheets("Pipeline")

ws2.Activate

current = DatePart("q", ws1.range("d8").Value, 2)
getweeknumber = Int((13 + Day(ws1.range("d8").Value) - Weekday((ws1.range("d8").Value), vbMonday) - 5) / 7)

If current = 1 And getweeknumber = 2 Then
myfile = "MT.WesternMontana_"
ElseIf current = 1 And getweeknumber > 3 Then
myfile = "WY.GreaterWyoming_"
ElseIf current = 2 And getweeknumber = 2 Then
myfile = "WY.CheyenneWyoming_"
ElseIf current = 2 And getweeknumber > 3 Then
myfile = "SD.SouthDakota-MT.Montana_"
ElseIf current = 3 And getweeknumber = 2 Then
myfile = "OR.Oregon-WA.Washington_"
ElseIf current = 3 And getweeknumber > 3 Then
myfile = "ID.Idaho-WA.Washington_"
Else
End If


dtfile = Date
'dtfile = dateadd("m" -1, now())
' use the above comment if need to look back a month


filename = "G:\Review\" & myfile

If Len(filename1) = 0 Then
MsgBox "No Files were found.", vbExclamation
Exit Sub
End If

'Do While Len(filename) > 0
Do While filename <> ""
On Error Resume Next
'Set wbk = Workbooks.Open(filename & Format(dtfile, "mmddyyyy") & ".xlsx")
wbk = (filename & Format(dtfile, "mmddyyyy") & ".xlsx")
On Error GoTo 0
If Dir(wbk, vbDirectory) = vbNullString Then
'If wbk Is Nothing Then
dtfile = dtfile - 1
Else
Workbooks.Open (wbk)
Exit Do
End If
Loop

Set ws3 = Workbooks(myfile & Format(dtfile, "mmddyyyy"))



Workbooks(myfile & Format(dtfile, "mmddyyyy")).Sheets.Add(after:=Sheets("Pipeline")).Name = Format(Date, "mmddyyyy")
Set ws4 = Workbooks(myfile & Format(dtfile, "mmddyyyy")).Sheets(Format(Date, "mmddyyyy"))

With ws3.Sheets("Pipeline")
.Shapes("TextBox 4").TextFrame.Characters.Text = "Duplicate Loans"
.TextBoxes("TextBox 4").Copy
ws4.PasteSpecial
.Shapes("TextBox 4").TextFrame.Characters.Text = "Pipeline List"
End With


ws4.Rows("1:1").RowHeight = 27
ws4.Rows("2:2").RowHeight = 7.5
ws3.Sheets("Pipeline").Cells(3, 6).Copy
ws4.Cells(3, 1).PasteSpecial Paste:=xlPasteFormats
ws4.Cells(3, 1).PasteSpecial Paste:=xlPasteValues
ws4.Cells(3, 1).PasteSpecial Paste:=xlPasteColumnWidths

ws3.Sheets("Pipeline").Cells(3, 8).Copy
ws4.Cells(3, 2).PasteSpecial Paste:=xlPasteFormats
ws4.Cells(3, 2).PasteSpecial Paste:=xlPasteValues
ws4.Cells(3, 2).PasteSpecial Paste:=xlPasteColumnWidths

ws3.Sheets("Pipeline").Cells(3, 9).Copy
ws4.Cells(3, 3).PasteSpecial Paste:=xlPasteFormats
ws4.Cells(3, 3).PasteSpecial Paste:=xlPasteValues
ws4.Cells(3, 3).PasteSpecial Paste:=xlPasteColumnWidths

ws3.Sheets("Pipeline").Cells(3, 10).Copy
ws4.Cells(3, 4).PasteSpecial Paste:=xlPasteFormats
ws4.Cells(3, 4).PasteSpecial Paste:=xlPasteValues
ws4.Cells(3, 4).PasteSpecial Paste:=xlPasteColumnWidths

ws3.Sheets("Pipeline").Cells(3, 11).Copy
ws4.Cells(3, 5).PasteSpecial Paste:=xlPasteFormats
ws4.Cells(3, 5).PasteSpecial Paste:=xlPasteValues
ws4.Cells(3, 5).PasteSpecial Paste:=xlPasteColumnWidths

ws3.Sheets("Pipeline").Cells(3, 22).Copy
ws4.Cells(3, 6).PasteSpecial Paste:=xlPasteFormats
ws4.Cells(3, 6).PasteSpecial Paste:=xlPasteValues
ws4.Cells(3, 6).PasteSpecial Paste:=xlPasteColumnWidths

ws4.Columns("F").ColumnWidth = 19.14


With ws2
lrow = .Cells(Rows.Count, "F").End(xlUp).Row
var1array = .range(.Cells(4, "F"), .Cells(lrow, "F")).Value
End With

With ws3.Sheets("Pipeline")
lrow = .Cells(Rows.Count, "F").End(xlUp).Row
var2array = .range(.Cells(4, "F"), .Cells(lrow, "F")).Value
End With


t = 1
w = 4

For i = 4 To UBound(var1array, 1)
j = 4
l = 1
blnmatch = False
Do While j <= UBound(var2array, 1) And blnmatch = False
If var2array(j, 1) = var1array(i, 1) Then
blnmatch = True
Exit Do
End If
j = j + 1
i = i + 1
Loop



'copy dupes
If blnmatch = True Then


For k = 6 To 22
k = 6
l = 1
If x = 0 Then
x = 4
Else
x = x + 1
End If

For l = t To 6
If k = 12 Then
k = 22
ElseIf k = 7 Then
k = 8
Else
    End If


ws2.Cells(i, k).Copy
ws4.Cells(x, l).PasteSpecial Paste:=xlPasteValues
ws4.Cells(x, l).PasteSpecial Paste:=xlPasteFormats
ws4.Cells(x, l).PasteSpecial Paste:=xlPasteColumnWidths
   k = k + 1


Next l
t = t + 1
Next k

End If
Next I


End Sub
 

Some videos you may like

Excel Facts

Will the fill handle fill 1, 2, 3?
Yes! Type 1 in a cell. Hold down Ctrl while you drag the fill handle.

CSmith

Well-known Member
Joined
Jan 13, 2020
Messages
686
Office Version
  1. 365
  2. 2010
  3. 2007
Platform
  1. Windows
  2. Mobile
  3. Web
See if this or this helps any?

Hello!!! I am trying to learn to code in vba on my own, but I simply cant achieve what I am wanting to do and need help. Below is my code I am working on. What I want to accomplish, is automatically pull up a worksheet that was saved in the past and compare it to the newest data. After comparing loan number's to see if they are a match, I want to paste certain columns of data in those rows with the duplicates and paste them to a new worksheet in the same workbook saved previously.

So far I am able to pull up the previously saved spreadsheet and compare the duplicates, but I am stuck when it comes to copying and pasting only certain items in those rows. Excuse the messy code below. I was trying to write a pra for loop by myself a the end there, but it is just getting out of hand. (as you can see). I am hoping someone can help me clean this up to work faster, and to properly copy and paste the duplicates. Specifically - if there is a duplicate loan, I want the data from that row (only from columns F-K, and V) to be pasted to the new worksheet with the sheet name of the current date and start pasting this data on row 4 columns A - F and move through the duplicates. I appreciate any help!

VBA Code:
Sub compare()
Dim last As Long
Dim filename As String, myfile As String
Dim strfile As String, dtfile As Date
Dim current As Integer, getweeknumber As Integer
Dim dic As Object, ar As Variant, arr As Variant, var As Variant
Dim v()
Dim i As Long, n As Long, j As Long, x As Long, k As Long, l As Long, t As Long, w As Long
Dim str As String
Dim ws As Worksheet, wbk1 As Workbook, ws3 As Workbook, ws1 As Worksheet, ws2 As Worksheet, ws4 As Worksheet
Dim wb, wb1 As Workbook
Dim var1array, var2array
Dim blnmatch As Boolean
Dim lrow As Long
Dim shp As Shape
Dim pt As PivotTable


Dim wbk As Variant, filename1 As String

Set ws1 = Workbooks("Review").Sheets("Ops")
Set wb = Workbooks("LO Review")
Set ws2 = Workbooks("LO Review").Sheets("Pipeline")

ws2.Activate

current = DatePart("q", ws1.range("d8").Value, 2)
getweeknumber = Int((13 + Day(ws1.range("d8").Value) - Weekday((ws1.range("d8").Value), vbMonday) - 5) / 7)

If current = 1 And getweeknumber = 2 Then
myfile = "MT.WesternMontana_"
ElseIf current = 1 And getweeknumber > 3 Then
myfile = "WY.GreaterWyoming_"
ElseIf current = 2 And getweeknumber = 2 Then
myfile = "WY.CheyenneWyoming_"
ElseIf current = 2 And getweeknumber > 3 Then
myfile = "SD.SouthDakota-MT.Montana_"
ElseIf current = 3 And getweeknumber = 2 Then
myfile = "OR.Oregon-WA.Washington_"
ElseIf current = 3 And getweeknumber > 3 Then
myfile = "ID.Idaho-WA.Washington_"
Else
End If


dtfile = Date
'dtfile = dateadd("m" -1, now())
' use the above comment if need to look back a month


filename = "G:\Review\" & myfile

If Len(filename1) = 0 Then
MsgBox "No Files were found.", vbExclamation
Exit Sub
End If

'Do While Len(filename) > 0
Do While filename <> ""
On Error Resume Next
'Set wbk = Workbooks.Open(filename & Format(dtfile, "mmddyyyy") & ".xlsx")
wbk = (filename & Format(dtfile, "mmddyyyy") & ".xlsx")
On Error GoTo 0
If Dir(wbk, vbDirectory) = vbNullString Then
'If wbk Is Nothing Then
dtfile = dtfile - 1
Else
Workbooks.Open (wbk)
Exit Do
End If
Loop

Set ws3 = Workbooks(myfile & Format(dtfile, "mmddyyyy"))



Workbooks(myfile & Format(dtfile, "mmddyyyy")).Sheets.Add(after:=Sheets("Pipeline")).Name = Format(Date, "mmddyyyy")
Set ws4 = Workbooks(myfile & Format(dtfile, "mmddyyyy")).Sheets(Format(Date, "mmddyyyy"))

With ws3.Sheets("Pipeline")
.Shapes("TextBox 4").TextFrame.Characters.Text = "Duplicate Loans"
.TextBoxes("TextBox 4").Copy
ws4.PasteSpecial
.Shapes("TextBox 4").TextFrame.Characters.Text = "Pipeline List"
End With


ws4.Rows("1:1").RowHeight = 27
ws4.Rows("2:2").RowHeight = 7.5
ws3.Sheets("Pipeline").Cells(3, 6).Copy
ws4.Cells(3, 1).PasteSpecial Paste:=xlPasteFormats
ws4.Cells(3, 1).PasteSpecial Paste:=xlPasteValues
ws4.Cells(3, 1).PasteSpecial Paste:=xlPasteColumnWidths

ws3.Sheets("Pipeline").Cells(3, 8).Copy
ws4.Cells(3, 2).PasteSpecial Paste:=xlPasteFormats
ws4.Cells(3, 2).PasteSpecial Paste:=xlPasteValues
ws4.Cells(3, 2).PasteSpecial Paste:=xlPasteColumnWidths

ws3.Sheets("Pipeline").Cells(3, 9).Copy
ws4.Cells(3, 3).PasteSpecial Paste:=xlPasteFormats
ws4.Cells(3, 3).PasteSpecial Paste:=xlPasteValues
ws4.Cells(3, 3).PasteSpecial Paste:=xlPasteColumnWidths

ws3.Sheets("Pipeline").Cells(3, 10).Copy
ws4.Cells(3, 4).PasteSpecial Paste:=xlPasteFormats
ws4.Cells(3, 4).PasteSpecial Paste:=xlPasteValues
ws4.Cells(3, 4).PasteSpecial Paste:=xlPasteColumnWidths

ws3.Sheets("Pipeline").Cells(3, 11).Copy
ws4.Cells(3, 5).PasteSpecial Paste:=xlPasteFormats
ws4.Cells(3, 5).PasteSpecial Paste:=xlPasteValues
ws4.Cells(3, 5).PasteSpecial Paste:=xlPasteColumnWidths

ws3.Sheets("Pipeline").Cells(3, 22).Copy
ws4.Cells(3, 6).PasteSpecial Paste:=xlPasteFormats
ws4.Cells(3, 6).PasteSpecial Paste:=xlPasteValues
ws4.Cells(3, 6).PasteSpecial Paste:=xlPasteColumnWidths

ws4.Columns("F").ColumnWidth = 19.14


With ws2
lrow = .Cells(Rows.Count, "F").End(xlUp).Row
var1array = .range(.Cells(4, "F"), .Cells(lrow, "F")).Value
End With

With ws3.Sheets("Pipeline")
lrow = .Cells(Rows.Count, "F").End(xlUp).Row
var2array = .range(.Cells(4, "F"), .Cells(lrow, "F")).Value
End With


t = 1
w = 4

For i = 4 To UBound(var1array, 1)
j = 4
l = 1
blnmatch = False
Do While j <= UBound(var2array, 1) And blnmatch = False
If var2array(j, 1) = var1array(i, 1) Then
blnmatch = True
Exit Do
End If
j = j + 1
i = i + 1
Loop



'copy dupes
If blnmatch = True Then


For k = 6 To 22
k = 6
l = 1
If x = 0 Then
x = 4
Else
x = x + 1
End If

For l = t To 6
If k = 12 Then
k = 22
ElseIf k = 7 Then
k = 8
Else
    End If


ws2.Cells(i, k).Copy
ws4.Cells(x, l).PasteSpecial Paste:=xlPasteValues
ws4.Cells(x, l).PasteSpecial Paste:=xlPasteFormats
ws4.Cells(x, l).PasteSpecial Paste:=xlPasteColumnWidths
   k = k + 1


Next l
t = t + 1
Next k

End If
Next I


End Sub
 

Watch MrExcel Video

Forum statistics

Threads
1,127,573
Messages
5,625,593
Members
416,121
Latest member
MrBuzz

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top