Copying the first instance of the a which occurs 'n' no.of times to a new workbook
Domanda
first of all thank you so much for bringing up such a site which is very helpful for people like me, who are starting to work with VBA. I am in the process of trying to automate a manual work that i do, which is really a time consuming one. Pls help me on this. The req. is as below:
X Y
---- ---
2134 100
2134 200
2134 300
3456 400
3241 500
2516 600
2516 700
I have a sheet with 'X' and 'Y' column as above. This is my source sheet, i have thousands of values like this and the rows gets added up daily(dynamic). I want the output sheet in a new workbook>>new sheet
and it should have the output as below:
X1 Y1
---- ---
2134 100
3456 400
3241 500
2516 600
i.e., the first instance of column 'X' and 'Y'. Please help me to get a VBA to do this automatically. I am spending 4 hours for this work daily as i need to manually update for 1000s of data.
THANKS in ADVANCE
Soluzione
Sub Firsts()
Dim dict As Object, k
Dim c As Range, tmp
Dim sht As Worksheet
Set dict = CreateObject("scripting.dictionary")
For Each c In ActiveSheet.Range("A1:A10000").Cells
tmp = c.Value
If Len(tmp) = 0 Then Exit For
If Not dict.exists(tmp) Then dict.Add tmp, c.Offset(0, 1).Value
Next c
DumpDict Workbooks.Add().Sheets(1).Range("A1"), dict
End Sub
Sub DumpDict(rng As Range, dict As Object)
Dim k, r As Long
r = 0
For Each k In dict.keys
rng.Cells(1).Offset(r, 0).Resize(1, 2).Value = Array(k, dict(k))
r = r + 1
Next
End Sub
Altri suggerimenti
Another option is to choose Advanced Filter from the Data Tab with the options below.
Now you can copy and paste the results to a new sheet and clear the filter
I believe this will get you what you want:
Sub copyOver()
Dim count As Integer
count = Application.WorksheetFunction.CountA(Range("A:A"))
Dim rowCount As Integer
rowCount = 1
Dim i As Integer
i = 2
Do While i <= count
Dim str As String
str = Range("A" & i)
Dim find As String
On Error GoTo copy:
find = Application.WorksheetFunction.VLookup(str, Range("A1:A" & (i - 1)), 1, False)
i = i + 1
Loop
Exit Sub
copy:
If (Range("A" & i) = "") Then
Resume Next
End If
Call copier(Range("A" & i), Range("B" & i), rowCount)
rowCount = rowCount + 1
Resume Next
End Sub
Sub copier(str1 As String, str2 As String, rowCount As Integer)
Worksheets("Sheet2").Range("A" & rowCount) = str1
Worksheets("Sheet2").Range("B" & rowCount) = str2
End Sub
Just make sure your data are in columns A and B and start below row 1. Hope this helps!