I have dataset from columns A to K and would like find duplicate rows of data from columns A, D, F, J and K.
I have the following code:
Sub RemoveDupes2()
Dim r As Long, lr As Long
Application.ScreenUpdating = False
lr = Cells.Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row
With Range("L2:L" & lr)
.Formula = "=ROW()"
.Value = .Value
End With
Range("A2:L" & lr).Sort Key1:=Range("A2"), Order1:=1, Key2:=Range("B2"), Order2:=1
With Range("M2:M" & lr)
.FormulaR1C1 = "=RC[-12]&RC[-11]&RC[-6]&RC[-4]&RC[-2]"
.Value = .Value
End With
With Range("N2:N" & lr)
.FormulaR1C1 = "=COUNTIF(R1C13:RC[-1],RC[-1])"
.Value = .Value
End With
For r = lr To 2 Step -1
If Cells(r, 14).Value > 2 Then
Rows(r).Delete
ElseIf Cells(r, 14).Value = 2 Then
Cells(r - 1, 1).Resize(, 7).Font.Bold = True
Rows(r).Delete
End If
Next r
lr = Cells.Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row
Range("A2:L" & lr).Sort Key1:=Range("L2"), Order1:=1
Range("L2:N" & lr).ClearContents
Application.ScreenUpdating = True
End Sub
The code currently deletes the entire data set and I am not sure why its doing so, as I am novice user to VBA.
https://www.dropbox.com/s/otgkk1igcd2995t/duplicates.xlsx
In your first With, please try changing:
.FormulaR1C1 = "=RC[-12]&RC[-11]&RC[-6]&RC[-4]&RC[-2]"
to
.FormulaR1C1 = "=RC[-12]&RC[-9]&RC[-7]&RC[-3]&RC[-2]"
There may well however be a separate issue because even unaltered the above code does not delete the entire dataset (for me, with Excel 2007).
Related
I have several codes of the same. I can remove duplicates only for these ones, which have the H-column empty. If the H column contains nonempty cell, the given code must stay.
I tried to work with IsEmpty() function, but it didn't work. The behaviour was as normal.
The code looks like this:
If IsEmpty(shTarget.Range("H" & lRow)) Then
With shTarget.Range("A" & lRow)
.PasteSpecial xlPasteValuesAndNumberFormats
.PasteSpecial xlPasteFormats
.RemoveDuplicates Columns:=1, Header:=xlYes
.Sort Key1:=.Columns(1), Order1:=xlAscending, Header:=xlYes
.WrapText = True
End With
End If
The approach with:
If shTarget.Range("H" & lRow) = "" Then
was exactly the same.
How can I retain the duplicate codes, which have value in other column?
UPDATE:
With this approach:
With shTarget.Range("A" & lRow)
.PasteSpecial xlPasteValuesAndNumberFormats
.PasteSpecial xlPasteFormats
If .Range("H" & lRow).Value = "" Then
.RemoveDuplicates Columns:=1, Header:=xlYes
End If
.Sort Key1:=.Columns(1), Order1:=xlAscending, Header:=xlYes
.WrapText = True
End With
I have an error:
Sort method of Range class failed
UPDATE II
Tried also have this one:
For Each r In rng
If r.Value = "" Then
shTarget.Range("A2:H" & lRow).RemoveDuplicates Columns:=1,
Header:=xlYes
End If
Next r
it still doesn't work. Basically, no difference was observed.
My full code is:
Sub CopyData_Cables(ByRef shSource As Worksheet, shTarget As Worksheet)
Const VHead As String = "A1:H1"
Const VMBom As String = "A2:H100"
shSource.Range(VHead).Copy
With shTarget.Range("A1")
.PasteSpecial xlPasteValues
.PasteSpecial xlPasteFormats
End With
Dim lRow As Long, lRow2 As Long
Dim i As Integer
lRow = shTarget.Cells(Rows.Count, "A").End(xlUp).Row + 1
shSource.Range(VMBom).Copy
Set Rng = shTarget.Range("H2" & lRow)
If IsEmpty(shTarget.Range("H" & lRow)) Then
With shTarget.Range("A" & lRow)
.PasteSpecial xlPasteValuesAndNumberFormats
.PasteSpecial xlPasteFormats
.RemoveDuplicates Columns:=1, Header:=xlYes
.Sort Key1:=.Columns(1), Order1:=xlAscending, Header:=xlYes
.WrapText = True
End With
End If
'If shTarget.Range("H2" & lRow) <> "" Then
'shTarget.Range("A" & lRow).Value = 0
'End If
'For Each r In Rng
' If r.Value = "" Then
'shTarget.Range("A2:A" & lRow).Value = "Kurs!"
' End If
' Next r
shTarget.Columns("A").ColumnWidth = 6.11
shTarget.Columns("B").ColumnWidth = 50
shTarget.Columns("C").ColumnWidth = 50
shTarget.Columns("D").ColumnWidth = 5.44
shTarget.Columns("E").ColumnWidth = 5.89
shTarget.Columns("F").ColumnWidth = 9
shTarget.Columns("G").ColumnWidth = 21.22
shTarget.Columns("H").ColumnWidth = 10.89
shTarget.Rows.EntireRow.AutoFit
For i = 3 To lRow Step 4
shTarget.Range(shTarget.Cells(i, 1), shTarget.Cells(i, 5)).Interior.Color = RGB(235, 235, 235)
shTarget.Range(shTarget.Cells(i, 7), shTarget.Cells(i, 8)).Interior.Color = RGB(235, 235, 235)
Next i
' Reset the clipboard.
Application.CutCopyMode = xlCopy
End Sub
Scan up the sheet deleting the duplicate rows.
Option Explicit
Sub RemoveDuplicates()
Dim ws As Worksheet, dict
Dim lastrow As Long, i As Long, n As Long
Dim key As String
Dim fso, ts
Set fso = CreateObject("Scripting.FilesystemObject")
Set ts = fso.CreateTextFile("debug.txt")
Set dict = CreateObject("Scripting.Dictionary")
Set ws = ThisWorkbook.Sheets("Sheet1")
With ws
lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
For i = lastrow To 2 Step -1
If Len(Trim(.Cells(i, "H"))) = 0 Then
key = Trim(.Cells(i, "A"))
If dict.exists(key) Then
'.Cells(i, "A").Interior.Color = vbRed
.Rows(i).Delete
n = n + 1
Else
dict.Add key, i
End If
Else
key = ""
End If
ts.writeline i & " A='" & .Cells(i, "A") & "' H='" _
& .Cells(i, "H") & "' key='" & key & "' n=" & n
Next
End With
ts.Close
MsgBox n & " rows deleted", vbInformation
End Sub
I wrote a script to find duplicate values in Colomn B. They can be alot of duplicates :
Value1
Value2
Value3
Value1
Value2
But never more than twice. I need to get the values from C column to M column from the second duplicate of B column and paste it on the first duplicate C to M column. After, i need to delete the second duplicate row.
The script work only for one instance of duplicate..
Sub hi()
Dim lastRow As Long
Dim matchFoundIndex As Long
Dim iCntr As Long
lastRow = Range("B100").End(xlUp).Row
For iCntr = 6 To lastRow
If Cells(iCntr, 2) <> "" Then
matchFoundIndex = WorksheetFunction.Match(Cells(iCntr, 2), Range("B1:B" & lastRow), 0)
If iCntr <> matchFoundIndex Then
Cells(iCntr, 3).Copy
Cells(matchFoundIndex, 3).Select
ActiveSheet.Paste
Cells(iCntr, 4).Copy
Cells(matchFoundIndex, 4).Select
ActiveSheet.Paste
Cells(iCntr, 5).Copy
Cells(matchFoundIndex, 5).Select
ActiveSheet.Paste
Cells(iCntr, 6).Copy
Cells(matchFoundIndex, 6).Select
ActiveSheet.Paste
Cells(iCntr, 7).Copy
Cells(matchFoundIndex, 7).Select
ActiveSheet.Paste
Cells(iCntr, 8).Copy
Cells(matchFoundIndex, 8).Select
ActiveSheet.Paste
Cells(iCntr, 9).Copy
Cells(matchFoundIndex, 9).Select
ActiveSheet.Paste
Cells(iCntr, 10).Copy
Cells(matchFoundIndex, 10).Select
ActiveSheet.Paste
Cells(iCntr, 11).Copy
Cells(matchFoundIndex, 11).Select
ActiveSheet.Paste
Cells(iCntr, 12).Copy
Cells(matchFoundIndex, 12).Select
ActiveSheet.Paste
Cells(iCntr, 13).Copy
Cells(matchFoundIndex, 13).Select
ActiveSheet.Paste
Rows(iCntr).EntireRow.Delete
End If
End If
Next
End Sub
Can you please help me clean this script ! Thank you !
Please, try using the next code. It uses a dictionary to keep the row of the first occurrence and copy the range C:M of the second occurrence to the first one. It does it without selecting, without using clipboard, in a fast way. All second occurrence cells are placed in a union range and deleted at the end, at once. In fact, the actual code only selects the rows containing the second occurrence. If it returns as you need, you only have to replace Select with Delete in the last code line:
Sub hi()
Dim lastRow As Long, iCntr As Long, rngDel As Range, dict As Object
lastRow = Range("B" & rows.count).End(xlUp).row
Set dict = CreateObject("Scripting.Dictionary")
For iCntr = 6 To lastRow
If cells(iCntr, 2) <> "" Then
If Not dict.Exists(cells(iCntr, 2).value) Then
dict.Add cells(iCntr, 2).value, iCntr 'the first occurrence row as item
Else
'copy the C:M range to the row of the first occurrence
Range("C" & dict(cells(iCntr, 2).value) & ":M" & dict(cells(iCntr, 2).value)).value = _
Range("C" & iCntr & ":M" & iCntr).value
If rngDel Is Nothing Then
Set rngDel = cells(iCntr, 2)
Else
Set rngDel = Union(rngDel, cells(iCntr, 2))
End If
End If
End If
Next
If Not rngDel Is Nothing Then rngDel.EntireRow.Select 'if selected what you need, replace Select with Delete
End Sub
The above code copies the rows of the second occurrence (C:M) to the row of the first one. Otherwise, it will not make any sense to copy anything on rows to be deleted...
I have a Userform with the following code attached to the "OK" button. All the code works fine other than the last 4 lines. Full code associated to OK button shown below, code not working is:
Dim SheetName As String
SheetName = ActiveSheet.Name
Call SheetCleanup
Worksheets(SheetName).Activate
It is as if it completely ignores it. SheetCleanup is located in a Module, and my suspicions are that there is an issue going from a Userform to a Module? But I am unfamiliar with this.
Full code is here:
Private Sub CommandButtonOK_Click()
If ComboBoxTargetEvent.Value = "" Or ComboBoxDesigner.Value = "" Or ComboBoxSignoff.Value = "" Or ComboBoxCarArea.Value = "" Or ComboBoxOriginator.Value = "" Or TextBoxNumberOfJobs.Value = "" Or ComboBoxProjectTitle.Value = "" Then _
MsgBox "You must complete all fields", vbInformation
Else:
'Go to worksheet based on Car Area
Dim CarArea As String
CarArea = ComboBoxCarArea.Value
Worksheets(CarArea).Activate
'Enter Target Event Into Column A
Columns("A").Find("", Cells(Rows.Count, "A")).Value = ComboBoxTargetEvent.Value
'Enter Project Title into column B
Columns("A").Find("", Cells(Rows.Count, "A")).Offset(-1, 1).Value = ComboBoxProjectTitle.Value
'Enter Designer name into column E
If _
ComboBoxDesigner.Value <> "Various" Then _
Columns("A").Find("", Cells(Rows.Count, "A")).Offset(-1, 4).Value = ComboBoxDesigner.Value
'Enter Sign-off name into column F
If _
ComboBoxSignoff.Value <> "Various" Then _
Columns("A").Find("", Cells(Rows.Count, "A")).Offset(-1, 5).Value = ComboBoxSignoff.Value
'Enter Originator name into column F
If _
ComboBoxOriginator.Value <> "Various" Then _
Columns("A").Find("", Cells(Rows.Count, "A")).Offset(-1, 3).Value = ComboBoxOriginator.Value
'Enter Data Formula into columns H & I
Columns("A").Find("", Cells(Rows.Count, "A")).Offset(-2, 7).Select
Columns("A").Find("", Cells(Rows.Count, "A")).Offset(-2, 7).Copy
Selection.Offset(1, 0).PasteSpecial Paste:=xlPasteFormulas
Columns("A").Find("", Cells(Rows.Count, "A")).Offset(-2, 8).Select
Columns("A").Find("", Cells(Rows.Count, "A")).Offset(-2, 8).Copy
Selection.Offset(1, 0).PasteSpecial Paste:=xlPasteFormulas
'Enter temp values into C & G
Columns("A").Find("", Cells(Rows.Count, "A")).Offset(-1, 2).Value = "ENTER DESCRIPTION HERE (CAPS LOCK ONLY)"
Columns("A").Find("", Cells(Rows.Count, "A")).Offset(-1, 6).Value = "ENTER DATE"
'Enter "N" into Job Completed
Columns("A").Find("", Cells(Rows.Count, "A")).Offset(-1, 9).Value = "N"
'Enter Data Validation List for Target Event
Dim ws As Worksheet
Dim NumberOfJobs As Long
Dim LastUsedInAA As Long
Dim range9 As Range
Set ws = ThisWorkbook.Worksheets("VBA_Data")
Set range9 = ws.Range("a:a")
LastUsedInAA = Range("A" & Rows.Count).End(xlUp).Row
NumberOfJobs = TextBoxNumberOfJobs.Value
If NumberOfJobs <> 0 Then
Range("A" & LastUsedInAA).Select
Selection.Resize(Selection.Rows.Count + NumberOfJobs - 1, _
Selection.Columns.Count).Select
With Selection.Validation
.Delete 'delete previous validation
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, _
Formula1:="='" & ws.Name & "'!" & range9.Address
End With
End If
'Enter Data Validation List for Designer
Dim LastUsedInE As Long
Dim range1 As Range
Set ws = ThisWorkbook.Worksheets("VBA_Data")
Set range1 = ws.Range("c:c")
LastUsedInE = Range("E" & Rows.Count).End(xlUp).Row
NumberOfJobs = TextBoxNumberOfJobs.Value
If NumberOfJobs <> 0 Then
Range("E" & LastUsedInE).Select
Selection.Resize(Selection.Rows.Count + NumberOfJobs - 1, _
Selection.Columns.Count).Select
With Selection.Validation
.Delete 'delete previous validation
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, _
Formula1:="='" & ws.Name & "'!" & range1.Address
End With
End If
'Enter Data Validation List for Senior Designer
Dim LastUsedInF As Long
Dim range2 As Range
Set ws = ThisWorkbook.Worksheets("VBA_Data")
Set range2 = ws.Range("b:b")
LastUsedInF = Range("F" & Rows.Count).End(xlUp).Row
NumberOfJobs = TextBoxNumberOfJobs.Value
If NumberOfJobs <> 0 Then
Range("F" & LastUsedInF).Select
Selection.Resize(Selection.Rows.Count + NumberOfJobs - 1, _
Selection.Columns.Count).Select
With Selection.Validation
.Delete
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, _
Formula1:="='" & ws.Name & "'!" & range2.Address
End With
End If
'Enter Data Validation List for Originator
Dim LastUsedInD As Long
Dim range5 As Range
Set ws = ThisWorkbook.Worksheets("VBA_Data")
Set range5 = ws.Range("f:f")
LastUsedInD = Range("D" & Rows.Count).End(xlUp).Row
NumberOfJobs = TextBoxNumberOfJobs.Value
If NumberOfJobs <> 0 Then
Range("d" & LastUsedInD).Select
Selection.Resize(Selection.Rows.Count + NumberOfJobs - 1, _
Selection.Columns.Count).Select
With Selection.Validation
.Delete
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, _
Formula1:="='" & ws.Name & "'!" & range5.Address
End With
End If
'Enter Data Validation List for Job Completed
Dim LastUsedInJ As Long
Dim range3 As Range
Set ws = ThisWorkbook.Worksheets("VBA_Data")
Set range3 = ws.Range("d:d")
LastUsedInJ = Range("J" & Rows.Count).End(xlUp).Row
NumberOfJobs = TextBoxNumberOfJobs.Value
If NumberOfJobs <> 0 Then
Range("J" & LastUsedInJ).Select
Selection.Resize(Selection.Rows.Count + NumberOfJobs - 1, _
Selection.Columns.Count).Select
With Selection.Validation
.Delete 'delete previous validation
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, _
Formula1:="='" & ws.Name & "'!" & range3.Address
End With
End If
'Multiply rows for multiple jobs
Dim LastUsedInA As Long
LastUsedInA = Range("A" & Rows.Count).End(xlUp).Row
NumberOfJobs = TextBoxNumberOfJobs.Value
If NumberOfJobs <> 1 Then
Range("A" & LastUsedInA).Select
Selection.Resize(Selection.Rows.Count, _
Selection.Columns.Count + 10).Copy
Range("A" & LastUsedInA + 1).Select
Selection.Resize(Selection.Rows.Count + NumberOfJobs - 2, _
Selection.Columns.Count).Select
Selection.PasteSpecial Paste:=xlPasteValues
Selection.PasteSpecial Paste:=xlPasteFormulas
End If
'Clear the clipboard
Application.CutCopyMode = False
'select last cell in A
Range("A" & LastUsedInA).Select
'Clear all fields before hide
ComboBoxTargetEvent.Value = ""
ComboBoxDesigner.Value = ""
ComboBoxSignoff.Value = ""
ComboBoxCarArea.Value = ""
ComboBoxOriginator.Value = ""
TextBoxNumberOfJobs.Value = ""
ComboBoxProjectTitle.Value = ""
'Hide Window
CreateJobs.Hide
End If
Dim SheetName As String
SheetName = ActiveSheet.Name
Call SheetCleanup
Worksheets(SheetName).Activate
End Sub
Code for SheetCleanup is as follows:
Public Sub SheetCleanup()
'Clan-up on Car Area WorkSheets
Application.ScreenUpdating = False
Dim sh As Worksheet
For Each sh In ActiveWorkbook.Worksheets
Select Case sh.Name
Case Is = "Contents Page", "Completed", "VBA_Data", "Front Team Project List", "Mid Team Project List", "Rear Team Project List", "Acronyms"
Case Else
With sh
'set zoom
sh.Activate
ActiveWindow.Zoom = 100
'format columns and rows
.Columns("g:g").NumberFormat = "dd-mm"
.Columns("i:i").NumberFormat = "0"
.Columns("A").ColumnWidth = 27
.Columns("B").ColumnWidth = 50
.Columns("C").ColumnWidth = 50
.Columns("D").ColumnWidth = 21
.Columns("E").ColumnWidth = 27
.Columns("F").ColumnWidth = 21
.Columns("G").ColumnWidth = 10
.Columns("H").ColumnWidth = 15
.Columns("I").ColumnWidth = 22
.Columns("J").ColumnWidth = 17
.Rows("1").RowHeight = 77.2
.Rows("2").RowHeight = 10
.Rows("3").RowHeight = 30
.Rows("4").RowHeight = 10
.Rows("5").RowHeight = 18
.Columns("a:j").HorizontalAlignment = xlCenter
.Columns("b:c").HorizontalAlignment = xlLeft
.Rows("3").HorizontalAlignment = xlCenter
.Rows("5").HorizontalAlignment = xlCenter
.Range("A:J").Validation.Delete
'set data validation for Target Event
Dim ws As Worksheet
Dim wsVBA As Worksheet
Dim range1 As Range, rng As Range
Dim LastRowTargetEvent As Long
Set wsVBA = ThisWorkbook.Worksheets("VBA_Data")
LastRowTargetEvent = wsVBA.Cells(.Rows.Count, "A").End(xlUp).Row
Set range1 = wsVBA.Range("A2:A" & LastRowTargetEvent)
Set ws = ActiveSheet
Set rng = ws.Range("a6:a1000")
With rng.Validation
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, _
Formula1:="='" & wsVBA.Name & "'!" & range1.Address
End With
End With
End Select
Next sh
End Sub
I know a bit of VBA, however I got a problem, I am trying to write a code that will copy all data from 1 sheet, append/paste it into the next blank cell in sheet 2 and then remove the data from sheet 1. I am using below code, but I get cell values replaced by the word TRUE.
Sub Instal_Sum_Paste()
ActiveWorkbook.Sheets("Vehicle working").Select
Dim N As Long
N = Cells(6, 2).End(xlDown).Row
Set DT = Range("b6:G" & N)
DT.Copy
ActiveWorkbook.Sheets("Installation Summary").Select
lMaxRows = Cells(Rows.Count, "B").End(xlUp).Row
Range("B" & lMaxRows + 1).Select
ActiveCell.Value = DT.PasteSpecial(xlPasteValues)
ActiveWorkbook.Sheets("Vehicle working").Select
DT.Select
Selection.ClearContents
MsgBox "done", vbOKOnly, "done"
End Sub
I managed to find an answer, its silly I know:
Sub Instal_Sum_Paste()
ActiveWorkbook.Sheets("Vehicle working").Select
Dim N As Long
N = Cells(6, 2).End(xlDown).Row
Set DT = Range("b6:G" & N)
DT.Select
Selection.Copy
ActiveWorkbook.Sheets("Installation Summary").Select
lMaxRows = Cells(Rows.Count, "B").End(xlUp).Row
Range("B" & lMaxRows + 1).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone
ActiveWorkbook.Sheets("Vehicle working").Select
DT.Select
Selection.ClearContents
MsgBox "done", vbOKOnly, "done"
End Sub
Can you anyone offer assistance on speeding up this code? I am assume an array can be used, but I am terrible using them. Is there another way? Thanks so much!
Application.ScreenUpdating = False
'IF using Indexed Values
If Sheets("interface").Range("C24") = "Y" Then
Dim x As Integer
Dim i As Long
For x = 15 To 51
LastRow = Sheets("db_main").Range("A" & Rows.Count).End(xlUp).Row
For i = 2 To LastRow
If Sheets("db_main").Range("S" & i) = True And Sheets("db_main").Range("C" & i) = Sheets("interface").Range("F" & x) Then
Sheets("db_main").Range("C" & i).Copy
Sheets("intersource").Range("A" & Rows.Count).End(xlUp).Offset(1).Select
Selection.PasteSpecial Paste:=xlPasteValues
Sheets("db_main").Range("A" & i).Copy
Sheets("intersource").Range("B" & Rows.Count).End(xlUp).Offset(1).Select
Selection.PasteSpecial Paste:=xlPasteValues
Sheets("db_main").Range("H" & i).Copy
Sheets("intersource").Range("C" & Rows.Count).End(xlUp).Offset(1).Select
Selection.PasteSpecial Paste:=xlPasteValues
Sheets("db_main").Range("D" & i).Copy
Sheets("intersource").Range("D" & Rows.Count).End(xlUp).Offset(1).Select
Selection.PasteSpecial Paste:=xlPasteValues
Sheets("db_main").Range("M" & i).Copy
Sheets("intersource").Range("E" & Rows.Count).End(xlUp).Offset(1).Select
Selection.PasteSpecial Paste:=xlPasteValues
Sheets("db_main").Range("O" & i).Copy
Sheets("intersource").Range("F" & Rows.Count).End(xlUp).Offset(1).Select
Selection.PasteSpecial Paste:=xlPasteValues
End If
Next i
Next x
End If
If you'd like to avoid using arrays, you could try eliminating the copy/paste in favor of just assigning values (which should improve the performance). Try this out:
'IF using Indexed Values
Application.ScreenUpdating = False
If Sheets("interface").Range("C24") = "Y" Then
Dim x As Long, i As Long, LastRow As Long, _
LastSourceRow As Long, Counter As Long
Dim DBSheet As Worksheet, SourceSheet As Worksheet, _
InterSheet As Worksheet
'identify worksheets for easier reference
Set DBSheet = ThisWorkbook.Worksheets("db_main")
Set SourceSheet = ThisWorkbook.Worksheets("intersource")
Set InterSheet = ThisWorkbook.Worksheets("interface")
For x = 15 To 51
'identify last rows
LastRow = DBSheet.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
LastSourceRow = SourceSheet.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
Counter = 1
For i = 2 To LastRow
If DBSheet.Range("S" & i) = True And DBSheet.Range("C" & i) = InterSheet.Range("F" & x) Then
'write DB column C to Source column A
SourceSheet.Cells(LastSourceRow + Counter, 1) = _
DBSheet.Cells(i, 3).Value
'write DB column A to Source column B
SourceSheet.Cells(LastSourceRow + Counter, 2) = _
DBSheet.Cells(i, 1).Value
'write DB column H to Source column C
SourceSheet.Cells(LastSourceRow + Counter, 3) = _
DBSheet.Cells(i, 8).Value
'write DB column D to source column D
SourceSheet.Cells(LastSourceRow + Counter, 4) = _
DBSheet.Cells(i, 4).Value
'write DB column M to Source column E
SourceSheet.Cells(LastSourceRow + Counter, 5) = _
DBSheet.Cells(i, 13).Value
'write DB column O to Source column F
SourceSheet.Cells(LastSourceRow + Counter, 6) = _
DBSheet.Cells(i, 15).Value
'increment counter
Counter = Counter + 1
End If
Next i
Next x
End If
Application.ScreenUpdating = True