VBA to find unique value and copy adjacent cell to new worksheet

V

VBA Clueless

New Member
Joined
Mar 11, 2015
Messages
4
I am attempting to create a vba script for excel to do the following task from a two column list of data (subnets and serial numbers) but am a COMPLETE VBA know-nothing. :confused:
• Check the 1st column (subnets) on ‘Sheet1’ for a unique value AND does not contain an “x” in its corresponding cell in column 3 (marker)
• Copy the value from the adjacent cell\column2 (Serial numbers) (on ‘Sheet1) and write to the first column on another worksheet (‘Sheet2’)
• Write a value in Column 3 as an identifier that its data has been copied over to the other sheet. This will allow me to pass through the list multiple times and ignore anything that has already been copied
• Loop/repeat through the list as many times as needed until reaching a specific number of results on Sheet2


Initial Spreadsheet

[table="width: 500, class: grid"]
[tr]
[td][/td]
[td]Column A[/td]
[td]Column B[/td]
[td]Column C[/td]
[/tr]
[tr]
[td]Row 1[/td]
[td]Subnet-A[/td]
[td]Serial-001[/td]
[td][/td]
[/tr]
[tr]
[td]Row 2[/td]
[td]Subnet-A[/td]
[td]Serial-002[/td]
[td][/td]
[/tr]
[tr]
[td]Row 3[/td]
[td]Subnet-A[/td]
[td]Serial-003[/td]
[td][/td]
[/tr]
[tr]
[td]Row 4[/td]
[td]Subnet-B[/td]
[td]Serial-004[/td]
[td][/td]
[/tr]
[tr]
[td]Row 5[/td]
[td]Subnet-B[/td]
[td]Serial-005[/td]
[td][/td]
[/tr]
[tr]
[td]Row 6[/td]
[td]Subnet-B[/td]
[td]Serial-006[/td]
[td][/td]
[/tr]
[tr]
[td]Row 7[/td]
[td]Subnet-C[/td]
[td]Serial-007[/td]
[td][/td]
[/tr]
[tr]
[td]Row 8[/td]
[td]Subnet-C[/td]
[td]Serial-008[/td]
[td][/td]
[/tr]
[tr]
[td]Row 9[/td]
[td]Subnet-D[/td]
[td]Serial-009[/td]
[td][/td]
[/tr]
[tr]
[td]Row 10[/td]
[td]Subnet-E[/td]
[td]Serial-010[/td]
[td][/td]
[/tr]
[tr]
[td]Row 11[/td]
[td]Subnet-E[/td]
[td]Serial-011[/td]
[td][/td]
[/tr]
[tr]
[td]Row 12[/td]
[td]Subnet-E[/td]
[td]Serial-012[/td]
[td][/td]
[/tr]
[tr]
[td]Row 13[/td]
[td]Subnet-F[/td]
[td]Serial-013[/td]
[td][/td]
[/tr]
[tr]
[td]Row 14[/td]
[td]Subnet-F[/td]
[td]Serial-014[/td]
[td][/td]
[/tr]
[tr]
[td]Row 15[/td]
[td]Subnet-F[/td]
[td]Serial-015[/td]
[td][/td]
[/tr]

[/table]


Workflow\My Logic - flawed as it may be ;)

[table="width: 1100, class: grid"]
[tr]
[td] Start VBA script [/td]
[td][/td]
[td]Column A[/td]
[td]Column B[/td]
[td](action1)[/td]
[td]Column C[/td]
[td] (action2)[/td]
[/tr]
[tr]
[td] Finds unique value "Subnet-A" in column A, finds no "x" in Column C, continues with actions [/td]
[td]Row 1[/td]
[td]Subnet-A[/td]
[td]Serial-001[/td]
[td] Writes an "X" in Column C -----> [/td]
[td] x [/td]
[td] Copies serial number value from Column B to Column A on Sheet2 [/td]
[/tr]
[tr]
[td] Subnet-A is no longer unique - moves to next row [/td]
[td]Row 2[/td]
[td]Subnet-A[/td]
[td]Serial-002[/td]
[td] [/td]
[td] [/td]
[td] [/td]

[/tr]
[tr]
[td] Subnet-A is no longer unique - moves to next row [/td]
[td]Row 3[/td]
[td]Subnet-A[/td]
[td]Serial-003[/td]
[td] [/td]
[td] [/td]
[td] [/td]
[/tr]
[tr]
[td] Finds unique value "Subnet-B" in column A, finds no "x" in Column C, continues with actions [/td]
[td]Row 4[/td]
[td]Subnet-B[/td]
[td]Serial-004[/td]
[td] Writes an "X" in Column C -----> [/td]
[td]x [/td]
[td] Copies serial number value from Column B to Column A on Sheet2 [/td]
[/tr]
[tr]
[td] Subnet-B is no longer unique - moves to next row [/td]
[td]Row 5[/td]
[td]Subnet-B[/td]
[td]Serial-005[/td]
[td] [/td]
[td] [/td]
[td] [/td]
[/tr]
[tr]
[td] Subnet-B is no longer unique - moves to next row [/td]
[td]Row 6[/td]
[td]Subnet-B[/td]
[td]Serial-006[/td]
[td] [/td]
[td] [/td]
[td] [/td]
[/tr]
[tr]
[td] Finds unique value "Subnet-C" in column A, finds no "x" in Column C, continues with actions [/td]
[td]Row 7[/td]
[td]Subnet-C[/td]
[td]Serial-007[/td]
[td] Writes an "X" in Column C -----> [/td]
[td]x [/td]
[td] Copies serial number value from Column B to Column A on Sheet2 [/td]

[/tr]
[tr]
[td] Subnet-C is no longer unique - moves to next row [/td]
[td]Row 8[/td]
[td]Subnet-C[/td]
[td]Serial-008[/td]
[td] [/td]
[td] [/td]
[td] [/td]
[/tr]
[tr]
[td] Finds unique value "Subnet-D" in column A, finds no "x" in Column C, continues with actions [/td]
[td]Row 9[/td]
[td]Subnet-D[/td]
[td]Serial-009[/td]
[td] Writes an "X" in Column C -----> [/td]
[td]x [/td]
[td] Copies serial number value from Column B to Column A on Sheet2 [/td]

[/tr]
[tr]
[td] Finds unique value "Subnet-E" in column A, finds no "x" in Column C, continues with actions [/td]
[td]Row 10[/td]
[td]Subnet-E[/td]
[td]Serial-010[/td]
[td] Writes an "X" in Column C -----> [/td]
[td]x [/td]
[td] Copies serial number value from Column B to Column A on Sheet2 [/td]
[/tr]
[tr]
[td] Subnet-E is no longer unique - moves to next row [/td]
[td]Row 11[/td]
[td]Subnet-E[/td]
[td]Serial-011[/td]
[td] [/td]
[td] [/td]
[td] [/td]
[/tr]
[tr]
[td] Subnet-E is no longer unique - moves to next row [/td]
[td]Row 12[/td]
[td]Subnet-E[/td]
[td]Serial-012[/td]
[td] [/td]
[td] [/td]
[td] [/td]
[/tr]
[tr]
[td] Finds unique value "Subnet-F" in column A, finds no "x" in Column C, continues with actions [/td]
[td]Row 13[/td]
[td]Subnet-F[/td]
[td]Serial-013[/td]
[td] Writes an "X" in Column C -----> [/td]
[td]x [/td]
[td] Copies serial number value from Column B to Column A on Sheet2 [/td]
[/tr]
[tr]
[td] Subnet-F is no longer unique - moves to next row [/td]
[td]Row 14[/td]
[td]Subnet-F[/td]
[td]Serial-014[/td]
[td] [/td]
[td] [/td]
[td] [/td]
[/tr]
[tr]
[td] Subnet-F is no longer unique - moves to next row [/td]
[td]Row 15[/td]
[td]Subnet-F[/td]
[td]Serial-015[/td]
[td] [/td]
[td] [/td]
[td] [/td]
[/tr]

[/table]


Desired results on ‘Sheet2’ based on above logic

[table="width: 200, class: grid"]

[tr]
[td]Sheet2 - Column A[/td]
[/tr]
[tr]
[td]Serial-001[/td]
[/tr]
[tr]
[td]Serial-004[/td]
[/tr]
[tr]
[td]Serial-007[/td]
[/tr]
[tr]
[td]Serial-009[/td]
[/tr]
[tr]
[td]Serial-010[/td]
[/tr]
[tr]
[td]Serial-013[/td]
[/tr]

[/table]

The VBA code I have so far only parses Column A and copies the unique data to sheet2 (it’s a start right). The code I have is as follows:


Public Sub MyTest()
Sheet1.Range("A:A").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Sheet2.Range("A1"), Unique:=True
End Sub

Any help that can be provided would be greatly appreciated.

Warm Regards,
VBA Clueless
 

Excel Facts

Excel Wisdom
Using a mouse in Excel is the work equivalent of wearing a lanyard when you first get to college
Sort by date Sort by votes
VBA Clueless,

Welcome to the MrExcel forum.

1. What version of Excel and Windows are you using?

2. Are you using a PC or a Mac?

I assume that both Sheet1, and, Sheet2 already exist, and, that Sheet1 is sorted/grouped per your text display.

Here is a macro solution for you to consider.

Sample worksheets:


Excel 2007
ABC
1Subnet-ASerial-001
2Subnet-ASerial-002
3Subnet-ASerial-003
4Subnet-BSerial-004
5Subnet-BSerial-005
6Subnet-BSerial-006
7Subnet-CSerial-007
8Subnet-CSerial-008
9Subnet-DSerial-009
10Subnet-ESerial-010
11Subnet-ESerial-011
12Subnet-ESerial-012
13Subnet-FSerial-013
14Subnet-FSerial-014
15Subnet-FSerial-015
16
Sheet1



Excel 2007
A
1
2
3
4
5
6
7
Sheet2


After the macro, and, function:


Excel 2007
ABC
1Subnet-ASerial-001x
2Subnet-ASerial-002
3Subnet-ASerial-003
4Subnet-BSerial-004x
5Subnet-BSerial-005
6Subnet-BSerial-006
7Subnet-CSerial-007x
8Subnet-CSerial-008
9Subnet-DSerial-009x
10Subnet-ESerial-010x
11Subnet-ESerial-011
12Subnet-ESerial-012
13Subnet-FSerial-013x
14Subnet-FSerial-014
15Subnet-FSerial-015
16
Sheet1



Excel 2007
A
1Serial-001
2Serial-004
3Serial-007
4Serial-009
5Serial-010
6Serial-013
7
Sheet2


Please TEST this FIRST in a COPY of your workbook (always make a backup copy before trying new code, you never know what you might lose).

1. Copy the below macro code, and, function
2. Open your NEW workbook
3. Press the keys ALT + F11 to open the Visual Basic Editor
4. Press the keys ALT + I to activate the Insert menu
5. Press M to insert a Standard Module
6. Where the cursor is flashing, paste the code
7. Press the keys ALT + Q to exit the Editor, and return to Excel
8. To run the macro from Excel press ALT + F8 to display the Run Macro Dialog. Double Click the macro's name to Run it.

Code: 
Sub GetFirstUniqueSubnetSerialNumber()
' hiker95, 03/11/2015, ME841739
Dim r As Long, lr As Long, n As Long, nlr As Long
Dim o As Variant, j As Long
Application.ScreenUpdating = False
With Sheets("Sheet1")
  lr = .Cells(Rows.Count, 1).End(xlUp).Row
  nlr = CountUnique(.Range("A1:A" & lr))
  ReDim o(1 To nlr)
  For r = 1 To lr
    n = Application.CountIf(.Columns(1), .Cells(r, 1).Value)
    .Cells(r, 3) = "x"
    j = j + 1: o(j) = .Cells(r, 2).Value
    r = r + n - 1
  Next r
End With
With Sheets("Sheet2")
  .Columns(1).ClearContents
  .Cells(1, 1).Resize(UBound(o)) = Application.Transpose(o)
  .Columns(1).AutoFit
End With
Application.ScreenUpdating = True
End Sub
Function CountUnique(ByVal Rng As Range) As Long
' Juan Pablo González, MrExcel MVP, 05/09/2003
' http://www.mrexcel.com/forum/excel-questions/48385-need-count-unique-items-column-visual-basic-applications.html
Dim St As String
Set Rng = Intersect(Rng, Rng.Parent.UsedRange)
St = "'" & Rng.Parent.Name & "'!" & Rng.Address(False, False)
CountUnique = Evaluate("SUM(IF(LEN(" & St & "),1/COUNTIF(" & St & "," & St & ")))")
End Function

Before you use the macro with Excel 2007 or newer, save your workbook, Save As, a macro enabled workbook with the file extension .xlsm, and, answer the "do you want to enable macros" question as "yes" or "OK" (depending on the button label for your version of Excel) the next time you open your workbook.

Then run the GetFirstUniqueSubnetSerialNumber macro.
 
Upvote 0
Hiker95, Thank you for your quick reply to my post! I appreciate it! I will test your code this morning and get back to you with my results.

To answer your questions:
I am using Excel 2013 on a Windows 8.1 platform. Sheet 2 is already created and I do have my data sorted.

Thanks again and I will let you know how this works for me.
 
Upvote 0
Hiker95,

Your solution worked great! Thank you for your help!

Moving forward I hope to figure out how to make it interactive so I prompt me for the number of results I want (inputbox) and then loops through until it reaches the correct nuber of results on sheet2. But that I believe a another post.

Thanks again for a great solution!
 
Upvote 0
VBA Clueless,

Moving forward I hope to figure out how to make it interactive so I prompt me for the number of results I want (inputbox) and then loops through until it reaches the correct nuber of results on sheet2.
Click to expand...


The new macro has an Input Box:

Type in the number of results you want to display on Sheet2

Here are the results of the latest macro, where you are asked to enter a number, and you answer 3


Excel 2007
ABC
1Subnet-ASerial-001x
2Subnet-ASerial-002
3Subnet-ASerial-003
4Subnet-BSerial-004x
5Subnet-BSerial-005
6Subnet-BSerial-006
7Subnet-CSerial-007x
8Subnet-CSerial-008
9Subnet-DSerial-009x
10Subnet-ESerial-010x
11Subnet-ESerial-011
12Subnet-ESerial-012
13Subnet-FSerial-013x
14Subnet-FSerial-014
15Subnet-FSerial-015
16
Sheet1



Excel 2007
A
1Serial-001
2Serial-004
3Serial-007
4
5
6
7
Sheet2


Please TEST this FIRST in a COPY of your workbook (always make a backup copy before trying new code, you never know what you might lose).

1. Copy the below new macro code, and, new function
2. Open your NEW workbook
3. Press the keys ALT + F11 to open the Visual Basic Editor
4. Press the keys ALT + I to activate the Insert menu
5. Press M to insert a Standard Module
6. Where the cursor is flashing, paste the code
7. Press the keys ALT + Q to exit the Editor, and return to Excel
8. To run the macro from Excel press ALT + F8 to display the Run Macro Dialog. Double Click the macro's name to Run it.

Code: 
Sub GetFirstUniqueSubnetSerialNumberV2()
' hiker95, 03/12/2015, ME841739
Dim r As Long, lr As Long, n As Long, nlr As Long, ipb As Long, n2 As Long
Dim o As Variant, j As Long
With Sheets("Sheet1")
  lr = .Cells(Rows.Count, 1).End(xlUp).Row
  nlr = CountUniqueV2(.Range("A1:A" & lr))
  ipb = InputBox("Type in the number of results you want to display on Sheet2")
  If ipb < 1 Then
    MsgBox ("You entered a number less than 1 - macro terminated!")
    Exit Sub
  End If
  Application.ScreenUpdating = False
  If ipb < nlr Then
    ReDim o(1 To ipb)
  ElseIf ipb > nlr Then
    ReDim o(1 To ipb)
  ElseIf nlr = ipb Then
    ReDim o(1 To nlr)
  End If
  n2 = 0
  For r = 1 To lr
    n = Application.CountIf(.Columns(1), .Cells(r, 1).Value)
    .Cells(r, 3) = "x"
    n2 = n2 + 1
    If n2 > UBound(o) Then
      'do nothing
    Else
      j = j + 1: o(j) = .Cells(r, 2).Value
    End If
    r = r + n - 1
  Next r
End With
With Sheets("Sheet2")
  .Columns(1).ClearContents
  .Cells(1, 1).Resize(UBound(o)) = Application.Transpose(o)
  .Columns(1).AutoFit
End With
Application.ScreenUpdating = True
End Sub
Function CountUniqueV2(ByVal Rng As Range) As Long
' Juan Pablo González, MrExcel MVP, 05/09/2003
' http://www.mrexcel.com/forum/excel-questions/48385-need-count-unique-items-column-visual-basic-applications.html
Dim St As String
Set Rng = Intersect(Rng, Rng.Parent.UsedRange)
St = "'" & Rng.Parent.Name & "'!" & Rng.Address(False, False)
CountUniqueV2 = Evaluate("SUM(IF(LEN(" & St & "),1/COUNTIF(" & St & "," & St & ")))")
End Function

Before you use the macro with Excel 2007 or newer, save your workbook, Save As, a macro enabled workbook with the file extension .xlsm, and, answer the "do you want to enable macros" question as "yes" or "OK" (depending on the button label for your version of Excel) the next time you open your workbook.

Then run the GetFirstUniqueSubnetSerialNumberV2 macro.
 
Upvote 0
VBA Clueless,

Thanks for the feedback.

You are very welcome again. Glad I could help.

And, come back anytime.
 
Upvote 0
You must log in or register to reply here.

Similar threads

C
  • Solved
index match excel formula to vba code
Replies
9
Views
319
DanteAmor
DanteAmor
N
  • Question Question
Pivot graph data when creating a new tab from a template.
Replies
0
Views
239
Nippyzap
N
T
  • Question Question
VBA to populate cells on one worksheet with cells from another worksheet based on date help!!!
Replies
2
Views
355
Taekwon
T
L
  • Solved
VBA: need help matching range values to each other
2
Replies
10
Views
2K
Lil Stinker
L
B
  • Solved
VBA Help - Same Function needed for multiple sheets
Replies
2
Views
557
birdman15
B

Forum statistics

Threads
1,223,236
Messages
6,170,915
Members
452,366
Latest member
TePunaBloke

Share this page

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
Back
Top