I am a beginner in VBA, and I have done this if statement to fill in a column in a excel table.
The function is working ok, however it took almost an hour to run.
I need to increase the speed of it.
Table1 has 2600 rows
Table2 has 3200 rows
Can I help me?
Sub PreencherO()
Dim Current As Worksheet
Dim His As Worksheet
Dim Table1 As ListObject
Dim Table2 As ListObject
Set Table1 = ThisWorkbook.Worksheets("Current").ListObjects("Data")
Set Table2 = ThisWorkbook.Worksheets("His").ListObjects("Historical")
Dim irow As Long
irow = Table1.ListColumns(1).Range.Rows.Count
Dim lrow As Long
lrow = Table2.ListColumns(1).Range.Rows.Count
Dim i As Integer
Dim l As Integer
For i = 2 To irow
For l = 2 To lrow
If Table1.DataBodyRange.Cells(i, 6).Value = Table2.DataBodyRange.Cells(l, 6).Value Then
Table1.DataBodyRange.Cells(i, 20).Value = "OLD"
End If
Next l
Next i
End Sub
I need to increase the speed of it.
Use a Dictionary Object.
Option Explicit
Sub PreencherO()
Dim Table1 As ListObject, Table2 As ListObject
Dim i As Long, t0 As Single: t0 = Timer
With ThisWorkbook
Set Table1 = .Sheets("Current").ListObjects("Data")
Set Table2 = .Sheets("His").ListObjects("Historical")
End With
Dim dict As Object, key As String
Set dict = CreateObject("Scripting.Dictionary")
' fill dictionary with historic values
With Table2.DataBodyRange
'Debug.Print "Table2", .Address
For i = 1 To .Rows.Count
key = Trim(.Cells(i, 6))
If Len(key) > 0 Then
dict(key) = i
End If
Next
End With
' compare
Application.ScreenUpdating = False
With Table1.DataBodyRange
'Debug.Print "Table1", .Address
For i = 1 To .Rows.Count
key = Trim(.Cells(i, 6))
If dict.exists(key) Then
.Cells(i, 20).Value = "OLD"
End If
Next
End With
Application.ScreenUpdating = True
MsgBox "Completed in " & Format(Timer - t0, "0.0 secs"), vbInformation
End Sub
Related
My current code will attempt to copy entire rows based on the column A duplicated name to its respective worksheet using VBA as shown below. But it only works for the 1st duplicated name but not the rest. When i review my code, i realised that my target(at the part for target=Lbound to Ubound part) is always 0 so i was wondering why is it always 0 in this case? Because it suppose to be ranging from 0 to 3?
Sub test()
Dim ws As Worksheet: Set ws = ThisWorkbook.Sheets("Sheet1")
Dim cs As Worksheet
Dim mycell As Range, RANG As Range, Mname As String, Rng As Range
Dim r As Range, dict As Object
Set dict = CreateObject("Scripting.Dictionary")
With Sheets(1)
' Build a range (RANG) between cell F2 and the last cell in column F
Set RANG = Range(.Cells(2, "A"), .Cells(.Rows.count, "A").End(xlUp))
End With
' For each cell (mycell) in this range (RANG)
For Each mycell In RANG
Mname = mycell.Value
' If the count of mycell in RANG is greater than 1, then set the value of the cell 1 across to the right of mycell (i.e. column G) as "Duplicate Found"
If Application.WorksheetFunction.CountIf(RANG, mycell.Value) > 1 Then
If dict.count > 0 And dict.Exists(Mname) Then
dict(Mname) = mycell.Row()
Else
dict.Add Mname, mycell.Row()
End If
End If
Next mycell
Dim x As Long, Target As Long, i As Long
Dim CopyMe As Range
'Dim Arr: Arr = Array(Key)
Dim f As Variant
For x = 1 To 4
Set cs = ThisWorkbook.Sheets.Add(After:=Sheets(ThisWorkbook.Sheets.count))
cs.Name = "Names" & x
Next x
'Display result in debug window (Modify to your requirement)
Startrow = 2
For Each Key In dict.Keys
Set Rng = ws.Range("A" & Startrow & ":A" & dict(Key))
'Create 3 Sheets, move them to the end, rename
lr = dict(Key)
v = dict.Keys 'put the keys into an array
'Loop through each name in array
For Target = LBound(v) To UBound(v) - 1 '<-------why is Target always 0 here?
'Loop through each row
For i = Startrow To lr
'Create Union of target rows
If ws.Range("A" & i) = v(Target) Then
If Not CopyMe Is Nothing Then
Set CopyMe = Union(CopyMe, ws.Range("A" & i))
Else
Set CopyMe = ws.Range("A" & i)
End If
End If
Next i
Startrow = dict(Key) + 1
'Copy the Union to Target Sheet
If Not CopyMe Is Nothing And Target = 0 Then
CopyMe.EntireRow.Copy Destination:=ThisWorkbook.Sheets("Names1").Range("A1")
Set CopyMe = Nothing
End If
If Not CopyMe Is Nothing And Target = 1 Then
CopyMe.EntireRow.Copy Destination:=ThisWorkbook.Sheets("Names2").Range("A1")
Set CopyMe = Nothing
End If
If Not CopyMe Is Nothing And Target = 2 Then
CopyMe.EntireRow.Copy Destination:=ThisWorkbook.Sheets("Names3").Range("A1")
Set CopyMe = Nothing
End If
If Not CopyMe Is Nothing And Target = 3 Then
CopyMe.EntireRow.Copy Destination:=ThisWorkbook.Sheets("Names4").Range("A1")
Set CopyMe = Nothing
End If
Next Target
Next
End Sub
Main worksheet
In the case of duplicated John name:
In the case of duplicated Alice name
Updated code:
Sub test()
Dim ws As Worksheet: Set ws = ThisWorkbook.Sheets("Sheet1")
Dim cs As Worksheet
Dim mycell As Range, RANG As Range, Mname As String, Rng As Range
Dim r As Range, dict As Object
Set dict = CreateObject("Scripting.Dictionary")
With Sheets(1)
' Build a range (RANG) between cell F2 and the last cell in column F
Set RANG = Range(.Cells(2, "A"), .Cells(.Rows.Count, "A").End(xlUp))
End With
' For each cell (mycell) in this range (RANG)
For Each mycell In RANG
Mname = mycell.Value
' If the count of mycell in RANG is greater than 1, then set the value of the cell 1 across to the right of mycell (i.e. column G) as "Duplicate Found"
If Application.WorksheetFunction.CountIf(RANG, mycell.Value) > 1 Then
If dict.Count > 0 And dict.Exists(Mname) Then
dict(Mname) = mycell.Row()
Else
dict.Add Mname, mycell.Row()
End If
End If
Next mycell
Dim StartRow As Long
StartRow = 2
Dim Key As Variant
Dim lr As Long, v As Variant
For Each Key In dict.Keys
Set Rng = ws.Range("A" & StartRow & ":A" & dict(Key))
lr = dict(Key)
v = dict.Keys 'put the keys into an array
'Create 3 Sheets, move them to the end, rename
'Loop through each name in array
For Target = LBound(v) To UBound(v) - 1 '<-------why is Target always 0 here?
'Loop through each row
For i = StartRow To lr
'Create Union of target rows
If ws.Range("A" & i) = v(Target) Then
If Not CopyMe Is Nothing Then '<---object required error at If Not copyme...
Set CopyMe = Union(CopyMe, ws.Range("A" & i))
Else
Set CopyMe = ws.Range("A" & i)
End If
End If
Next i
StartRow = dict(Key) + 1
'Copy the Union to Target Sheet
If Not CopyMe Is Nothing Then
Mname = "Name" & CStr(Target + 1)
CopyMe.EntireRow.Copy Destination:=ThisWorkbook.Sheets(Mname).Range("A1")
Set CopyMe = Nothing
End If
Next Target
Next Key
End Sub
Use a dictionary for the start row and another for the end row. It is then straightforward to determine the range of duplicate rows for each name and copy them to a new sheet.
Sub CopyDuplicates()
Dim wb As Workbook, ws As Worksheet
Dim irow As Long, iLastRow As Long
Dim dictFirstRow As Object, dictLastRow As Object, sKey As String
Set dictFirstRow = CreateObject("Scripting.Dictionary") ' first row for name
Set dictLastRow = CreateObject("Scripting.Dictionary") ' last row for name
Set wb = ThisWorkbook
Set ws = wb.Sheets("Sheet1")
iLastRow = ws.Range("A" & Rows.Count).End(xlUp).Row
' build dictionaries
For irow = 1 To iLastRow
sKey = ws.Cells(irow, 1)
If dictFirstRow.exists(sKey) Then
dictLastRow(sKey) = irow
Else
dictFirstRow.Add sKey, irow
dictLastRow.Add sKey, irow
End If
Next
' copy range of duplicates
Dim k, iFirstRow As Long, rng As Range, wsNew As Worksheet
For Each k In dictFirstRow.keys
iFirstRow = dictFirstRow(k)
iLastRow = dictLastRow(k)
' only copy duplicates
If iLastRow > iFirstRow Then
Set wsNew = wb.Worksheets.Add(after:=wb.Sheets(wb.Sheets.Count))
wsNew.Name = k
Set rng = ws.Rows(iFirstRow & ":" & iLastRow).EntireRow
rng.Copy wsNew.Range("A1")
Debug.Print k, iFirstRow, iLastRow, rng.Address
End If
Next
MsgBox "Done"
End Sub
I couldn't find a mistake because I didn't want to set up the workbook that would enable me to test your code thoroughly. However, I did read through your code and found that you were very lax on declaring variables. I suggest you enter Option Explicit at the top of your code.
To call a Key a "Key" is asking for trouble. Best practice suggests that you don't use VBA key words as variable names. In the context of your code, For Each Key In Dict.Keys requires Key to be a variant. Being undeclared would make it a variant by default but if it's also a word VBA reserves for its own use confusion might arise.
Another idea is that you might have put a break point on For Target = LBound(v) To UBound(v) - 1. When the code stops there Target will be zero because the line hasn't executed yet. But after the first loop execution will not return to this line. So you might have missed Target taking on a value and the error might be elsewhere. Make sure you place the break point on the first line after the For statement. You might also add Debug.Print LBound(v), UBound(v) before the For statement or check these values in the Locals window.
Below is the section of the code where I added several variable declarations and made an amendment to the code that creates and names the new sheets.
Dim StartRow As Long
StartRow = 2
Dim Key As Variant
Dim lr As Long, v As Variant
For Each Key In Dict.Keys
Set Rng = Ws.Range("A" & StartRow & ":A" & Dict(Key))
lr = Dict(Key)
v = Dict.Keys 'put the keys into an array
'Create 3 Sheets, move them to the end, rename
'Loop through each name in array
For Target = LBound(v) To UBound(v) - 1 '<-------why is Target always 0 here?
'Loop through each row
For i = StartRow To lr
'Create Union of target rows
If Ws.Range("A" & i) = v(Target) Then
If Not CopyMe Is Nothing Then
Set CopyMe = Union(CopyMe, Ws.Range("A" & i))
Else
Set CopyMe = Ws.Range("A" & i)
End If
End If
Next i
StartRow = Dict(Key) + 1
'Copy the Union to Target Sheet
If Not CopyMe Is Nothing Then
Mname = "Name" & CStr(Target + 1)
CopyMe.EntireRow.Copy Destination:=ThisWorkbook.Sheets(Mname).Range("A1")
Set CopyMe = Nothing
End If
Next Target
Next Key
John, I spent an hour working my way through your code - correcting and commenting. I got a real good feeling of how confidence escaped from your mind as you went into the last third of the code. The same thing happened to me. I saw, as you probably did, that the concept was so far off the mark that it is very hard to salvage. So I wrote code that probably does what you want. Please try it.
Sub TransferData()
Dim Src As Variant ' source data
Dim Ws As Worksheet ' variable target sheet
Dim WsName As String
Dim Rl As Long ' last row
Dim R As Long ' row
Dim C As Long ' column
With ThisWorkbook.Sheets("TestData")
' Copy all values between cell A2 and the last cell in column F
Rl = .Cells(.Rows.Count, "A").End(xlUp).Row
Src = Range(.Cells(2, "A"), .Cells(Rl, "F")).Value
End With
Application.ScreenUpdating = False
For R = 1 To UBound(Src)
WsName = Trim(Split(Src(R, 1))(0)) ' first word in A2 etc
On Error Resume Next
Set Ws = Worksheets(WsName)
If Err Then
With ThisWorkbook.Sheets
Set Ws = .Add(After:=Sheets(.Count))
End With
Ws.Name = WsName
End If
On Error Goto 0
' append data
With Ws
Rl = .Cells(.Rows.Count, "A").End(xlUp).Row
For C = 1 To UBound(Src, 2)
With .Rows(Rl + 1)
.Cells(C).Value = Src(R, C)
End With
Next C
End With
Next R
Application.ScreenUpdating = True
End Sub
The code doesn't use a dictionary. That's why it is much shorter and much more efficient, too. It just sorts the data directly to different sheets based on what it finds in column A. There is no limit to the number of sheets you might need.
Observe that the sheet on which I had the data is called "TestData" in this code. It should be the one in your project that responded to the moniker Sheets(1), most likely aka ThisWorkbook.Worksheets("Sheet1").
I want to remove duplicates based on the text in Column I and sum the values in Column C, the data in the other columns doesn't matter.
I do not want a pivot table and I am aware they are the preferred option for this type of thing.
An example of what I'd like to achieve:
I found VBA code and tried to modify it. It doesn't delete all the lines.
Sub Sum_and_Dedupe()
With Worksheets("data")
'deal with the block of data radiating out from A1
With .Cells(1, 1).CurrentRegion
'step off the header and make one column wider
With .Resize(.Rows.Count - 1, .Columns.Count + 1).Offset(1, 0)
.Columns(.Columns.Count).Formula = "=sumifs(c:c, i:i, i2)"
.Columns(3) = .Columns(.Columns.Count).Value
.Columns(.Columns.Count).Delete
End With
'remove duplicates
.RemoveDuplicates Columns:=Array(9), Header:=xlYes
End With
.UsedRange
End With
End Sub
This should be an answer to your question.
However, code might require adaptation if the range in which you look becomes very long.
Option Explicit
Sub test()
Dim wb As Workbook
Dim ws As Worksheet
Dim LastRow As Long, LastCol As Long, a As Double, i As Long
Dim Rng As Range
Dim Cell As Variant, Estimate As Variant
Set wb = ThisWorkbook
Set ws = wb.Sheets(1)
LastRow = ws.Cells(ws.Rows.Count, "I").End(xlUp).Row
LastCol = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column
Set Rng = ws.Range(ws.Cells(2, 9), ws.Cells(LastRow, 9))
For Each Cell In Rng
i = 0
a = 0
For Each Estimate In Rng
If Estimate.Value = Cell.Value Then
i = i + 1 'Count nr of intances
a = a + ws.Cells(Estimate.Row, 3).Value 'sum booking value
If i > 1 Then
ws.Rows(Estimate.Row).Delete
i = 1
LastRow = LastRow - 1
End If
End If
Next Estimate
ws.Cells(Cell.Row, 3).Value = a 'Enter sum in booked this week
Next Cell
End Sub
You'll either need to change your current sheet name to data, or change the first two lines of this code to fit your needs. sh = the data sheet that you showed us. osh = an output sheet that this code will generate. Note also if column C or I move you can update the positions easily by changing colBooked and colEstimate. If you have more than a thousand unique estimate entries then make the array number larger than 999.
Sub summariseEstimates()
Dim sh As String: sh = "data"
Dim osh As String: osh = "summary"
Dim colBooked As Integer: colBooked = 3
Dim colEstimate As Integer: colEstimate = 9
Dim myArray(999) As String
Dim shCheck As Worksheet
Dim output As Worksheet
Dim lastRow As Long
Dim a As Integer: a = 0
Dim b As Integer
Dim r As Long 'row anchor
Dim i As Integer 'sheets
'Build summary array:
With Worksheets(sh)
lastRow = .Cells.Find("*", searchorder:=xlByRows, searchdirection:=xlPrevious).Row
For r = 2 To lastRow
If r = 2 Then 'first entry
myArray(a) = .Cells(r, colEstimate) & "," & .Cells(r, colBooked)
Else
For b = 0 To a
If VBA.LCase(VBA.Replace(.Cells(r, colEstimate), " ", "")) = VBA.LCase(VBA.Replace(VBA.Split(myArray(b), ",")(0), " ", "")) Then 'match
myArray(b) = VBA.Split(myArray(b), ",")(0) & "," & VBA.Split(myArray(b), ",")(1) + .Cells(r, colBooked)
Exit For
End If
Next b
If b = a + 1 Then 'completed loop = no match, create new array item:
a = a + 1
myArray(a) = .Cells(r, colEstimate) & "," & .Cells(r, colBooked)
End If
End If
Next r
End With
'Create summary sheet:
On Error Resume Next
Set shCheck = Worksheets(osh)
If Err.Number <> 0 Then
On Error GoTo 0
Set output = Worksheets.Add(After:=Worksheets(sh))
output.Name = osh
Err.Clear
Else
On Error GoTo 0
If MsgBox("*" & osh & "* sheet already exists. Proceed to delete and recreate?", vbOKCancel, "Summary") = vbCancel Then
Exit Sub
Else
Application.DisplayAlerts = False
Worksheets(osh).Delete
Set output = Worksheets.Add(After:=Worksheets(sh))
output.Name = osh
End If
End If
'Output to summary sheet:
With Worksheets(osh)
.Cells(1, 1).Value = "ESTIMATE"
.Cells(1, 2).Value = "BOOKED THIS WEEK"
For b = 0 To a
.Cells(b + 2, 1).Value = VBA.Split(myArray(b), ",")(0)
.Cells(b + 2, 2).Value = VBA.Split(myArray(b), ",")(1)
Next b
.Columns("A:B").AutoFit
End With
End Sub
New to VBA
I am trying to copy rows containing a month from a table and paste them into cells. However, they paste upward instead of downward. Any help is appreciated.
Sub tblcopypast()
Dim Month As String
Dim tbl As ListObject
Dim i As Integer
Dim lastrow As Integer
Set tbl = ActiveSheet.ListObjects("Table1")
Month = ActiveSheet.Range("E1").Value
lastrow = tbl.ListRows.Count
For i = 1 To lastrow
If tbl.DataBodyRange(i, 2) = Month Then
tbl.ListRows(i).Range.Copy
ActiveSheet.Range("rng").End(xlUp).Offset(1, 0).PasteSpecial xlPasteValuesAndNumberFormats
End If
Next
End Sub
Your ActiveSheet.Range("rng").End(xlUp).Offset(1, 0).PasteSpecial is quite tricky. Especially in a loop. Try below code:
Option Explicit
Sub tblcopypast()
Dim Month As String
Dim tbl As ListObject
Dim iCt As Integer
Dim jCt As Integer
Dim lastrow As Integer
Dim targetRange As Range
Dim actRange As Range
Set tbl = ActiveSheet.ListObjects("Table1")
Month = ActiveSheet.Range("E1").Value
lastrow = tbl.ListRows.Count
jCt = 0
Set actRange = ActiveCell
Set targetRange = ActiveSheet.Range("rng").End(xlUp).Offset(1, 0)
For iCt = 1 To lastrow
If tbl.DataBodyRange(iCt, 2) = Month Then
tbl.ListRows(iCt).Range.Copy
targetRange.Offset(jCt, 0).PasteSpecial xlPasteValues
jCt = jCt + 1
End If
Next
actRange.Select
End Sub
Sub DefineSamples()
'sample data I used to review your code!
Dim cell As Range
Range("M1") = "F1"
Range("N1") = "F2"
Range("O1") = "F3"
Range("P1") = "F4"
For Each cell In Range("M2:P12")
cell.Value = Int(Rnd() * 100)
Next cell
Range("E1").Value = "Jan"
Range("N3").Value = "Jan"
Range("N5").Value = "Jan"
Range("N7").Value = "Jan"
Range("N9").Value = "Jan"
Range("N10").Value = "Jan"
Range("N11").Value = "Jan"
On Error Resume Next
ActiveSheet.ListObjects.Add(xlSrcRange, Range("$M$1:$P$12"), , xlYes).Name = "Table1"
On Error GoTo 0
Range("Table1").HorizontalAlignment = xlCenter
End Sub
I am looking to fill a spreadsheet with data repeating data, so 25 appointments for today, 25 appointments for tomorrow with the same name and so on for as far as possible.
Is the a simple way of filling the table where the date increases in blocks of 25?
Example of what i am trying to do
Try using this you might be able to achieve what you want ,any problems shout out
'to change the date to the next day
Public Function ExtraDay(strDate As String)
Dim tDay As Date
tDay = Format(DateAdd("d", 1, strDate), "dd/mm/yy")
ExtraDay = tDay
End Function
'gets the last used row
Function getThelastUsedRowAddress() As Integer
'Get Last Row in Worksheet UsedRange
Dim LastRow As Range, ws As Worksheet
Set ws = ActiveSheet
MsgBox ws.UsedRange.Rows(ws.UsedRange.Rows.Count).Row
getThelastUsedRowAddress = ws.UsedRange.Rows(ws.UsedRange.Rows.Count).Row
End Function
'button command on the sheet
Private Sub CommandButton1_Click()
Dim n, t As Integer
Dim ns As String
n = getThelastUsedRowAddress()
t = n + n
ns = CStr(t)
Call getThelastUsedRow(CStr(n))
Call TheLoopRange(CStr(n) + 1, ns)
End Sub
'get the last used and paste after
Sub getThelastUsedRow(address As String)
'Get Last Row in Worksheet UsedRange
Dim LastRow As Range, ws As Worksheet
Dim numcopied As Integer
Dim numonpaper As Integer
Set ws = ActiveSheet
numcopied = ws.UsedRange.Rows(ws.UsedRange.Rows.Count).Row
numonpaper = numcopied + 1
ws.UsedRange.Copy 'Destination:=Wst.Cells(1, 1)
'paste
Sheets("Sheet1").Range("A" & numonpaper).PasteSpecial xlPasteValues
End Sub
'loop the pasted range and change date to the next day from date
Sub TheLoopRange(rangestart As String, rangeend As String)
'rangestart,rangeend
Dim rCell As Range
Dim rRng As Range
Set rRng = Sheet1.Range("E" & rangestart & ":E" & rangeend)
For Each rCell In rRng.Cells
'MsgBox rCell.Value
rCell.Value = ExtraDay(rCell.Value)
Next rCell
End Sub
Lets as assume that:
We use Sheet1
Company column is column D
Date column is column I
Pease try:
Option Explicit
Sub Test()
Dim Lastrow As Long, i As Long
With ThisWorkbook.Worksheets("Sheet1")
Lastrow = .Cells(.Rows.Count, "D").End(xlUp).Row
For i = 2 To Lastrow
If i = 2 Then
.Cells(i, 9).Value = Date + 1
ElseIf i <> 2 And .Cells(i, 4).Value = 1 Then
.Cells(i, 9).Value = .Cells(i, 9).Offset(-1, 0).Value + 1
Else: .Cells(i, 9).Value = .Cells(i, 9).Offset(-1, 0).Value
End If
Next i
End With
End Sub
I have a table with entries in various cells and would like to combine all the columns into one and remove any blanks or duplicates. I have developed this code, but can't get past ".Range("A100").Select." Any suggestions?
Private Sub CommandButton1_Click()
'Application.ScreenUpdating = False
Dim wb As Workbook
Dim wks2 As Worksheet, wks3 As Worksheet, wks5 As Worksheet
Dim cat As String, erow As Integer, lrow As Integer, i As Integer, j As Integer
Dim rr As Range, c As Collection, r As Range, L As Long
Set wb = ActiveWorkbook
Set wks2 = wb.Sheets(2)
Set wks3 = wb.Sheets(3)
Set wks5 = wb.Sheets(5)
'wks3.Activate
erow = wks3.Range("A" & Rows.Count).End(xlUp).Row 'Determines last row in the Cats-subCats sheet column A
'wks2.Activate
lrow = wks2.Range("I" & Rows.Count).End(xlUp).Row 'Determines last row in the DATA sheet column 9
For i = 2 To erow 'cycle through each category
'wks3.Activate
cat = wks3.Cells(i, 1) 'stores category name in variable cat
'wks2.Activate
For j = 2 To lrow 'cycle through each row of the DATA table
If wks2.Cells(j, 9) = cat Then
wks2.Cells(j, 20) = wks2.Cells(j, 10) 'temporarily stores the Weakness 1 values in column 20
wks2.Cells(j, 21) = wks2.Cells(j, 11) 'temporarily stores the Weakness 2 values in column 21
End If
Next j
MsgBox "pause"
wks2.Range("T1:U2000").Copy Destination:=wks5.Range("A1") 'copies the temporary selection from sheet 2 and pastes in Sheet 5
With wks5
Set c = New Collection
Set rr = Union(Intersect(Range("A:A"), ActiveSheet.UsedRange), Intersect(Range("B:B"), ActiveSheet.UsedRange))
On Error Resume Next
For Each r In rr
If r.Value <> "" Then
c.Add r.Value, CStr(r.Value)
End If
Next r
On Error GoTo 0
For L = 1 To c.Count
Cells(L, "C").Value = c.Item(L)
Next L
End With
Next i
Application.CutCopyMode = False 'clear any thing on clipboard to maximize available memory
Application.ScreenUpdating = True
End Sub
Inserted the suggested code, but get a run time error 1004 at the " Set rr = Union(Intersect(Range...." line...any further suggestions?
How about:
Sub WhatEver()
Dim rr As Range, c As Collection
Dim L As Long
Set c = New Collection
Set rr = Union(Intersect(Range("A:A"), ActiveSheet.UsedRange), Intersect(Range("B:B"), ActiveSheet.UsedRange))
On Error Resume Next
For Each r In rr
If r.Value <> "" Then
c.Add r.Value, CStr(r.Value)
End If
Next r
On Error GoTo 0
For L = 1 To c.Count
Cells(L, "C").Value = c.Item(L)
Next L
End Sub