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

[VBA Clueless]

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.
• 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

	Column A	Column B	Column C
Row 1	Subnet-A	Serial-001
Row 2	Subnet-A	Serial-002
Row 3	Subnet-A	Serial-003
Row 4	Subnet-B	Serial-004
Row 5	Subnet-B	Serial-005
Row 6	Subnet-B	Serial-006
Row 7	Subnet-C	Serial-007
Row 8	Subnet-C	Serial-008
Row 9	Subnet-D	Serial-009
Row 10	Subnet-E	Serial-010
Row 11	Subnet-E	Serial-011
Row 12	Subnet-E	Serial-012
Row 13	Subnet-F	Serial-013
Row 14	Subnet-F	Serial-014
Row 15	Subnet-F	Serial-015

Workflow\My Logic - flawed as it may be

Start VBA script		Column A	Column B	(action1)	Column C	(action2)
Finds unique value "Subnet-A" in column A, finds no "x" in Column C, continues with actions	Row 1	Subnet-A	Serial-001	Writes an "X" in Column C ----->	x	Copies serial number value from Column B to Column A on Sheet2
Subnet-A is no longer unique - moves to next row	Row 2	Subnet-A	Serial-002
Subnet-A is no longer unique - moves to next row	Row 3	Subnet-A	Serial-003
Finds unique value "Subnet-B" in column A, finds no "x" in Column C, continues with actions	Row 4	Subnet-B	Serial-004	Writes an "X" in Column C ----->	x	Copies serial number value from Column B to Column A on Sheet2
Subnet-B is no longer unique - moves to next row	Row 5	Subnet-B	Serial-005
Subnet-B is no longer unique - moves to next row	Row 6	Subnet-B	Serial-006
Finds unique value "Subnet-C" in column A, finds no "x" in Column C, continues with actions	Row 7	Subnet-C	Serial-007	Writes an "X" in Column C ----->	x	Copies serial number value from Column B to Column A on Sheet2
Subnet-C is no longer unique - moves to next row	Row 8	Subnet-C	Serial-008
Finds unique value "Subnet-D" in column A, finds no "x" in Column C, continues with actions	Row 9	Subnet-D	Serial-009	Writes an "X" in Column C ----->	x	Copies serial number value from Column B to Column A on Sheet2
Finds unique value "Subnet-E" in column A, finds no "x" in Column C, continues with actions	Row 10	Subnet-E	Serial-010	Writes an "X" in Column C ----->	x	Copies serial number value from Column B to Column A on Sheet2
Subnet-E is no longer unique - moves to next row	Row 11	Subnet-E	Serial-011
Subnet-E is no longer unique - moves to next row	Row 12	Subnet-E	Serial-012
Finds unique value "Subnet-F" in column A, finds no "x" in Column C, continues with actions	Row 13	Subnet-F	Serial-013	Writes an "X" in Column C ----->	x	Copies serial number value from Column B to Column A on Sheet2
Subnet-F is no longer unique - moves to next row	Row 14	Subnet-F	Serial-014
Subnet-F is no longer unique - moves to next row	Row 15	Subnet-F	Serial-015

Desired results on ‘Sheet2’ based on above logic

Sheet2 - Column A

Serial-001

Serial-004

Serial-007

Serial-009

Serial-010

Serial-013

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

 

[hiker95]

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
	A	B	C
1	Subnet-A	Serial-001
2	Subnet-A	Serial-002
3	Subnet-A	Serial-003
4	Subnet-B	Serial-004
5	Subnet-B	Serial-005
6	Subnet-B	Serial-006
7	Subnet-C	Serial-007
8	Subnet-C	Serial-008
9	Subnet-D	Serial-009
10	Subnet-E	Serial-010
11	Subnet-E	Serial-011
12	Subnet-E	Serial-012
13	Subnet-F	Serial-013
14	Subnet-F	Serial-014
15	Subnet-F	Serial-015
16
Sheet1

Excel 2007
	A
1
2
3
4
5
6
7
Sheet2

After the macro, and, function:

Excel 2007
	A	B	C
1	Subnet-A	Serial-001	x
2	Subnet-A	Serial-002
3	Subnet-A	Serial-003
4	Subnet-B	Serial-004	x
5	Subnet-B	Serial-005
6	Subnet-B	Serial-006
7	Subnet-C	Serial-007	x
8	Subnet-C	Serial-008
9	Subnet-D	Serial-009	x
10	Subnet-E	Serial-010	x
11	Subnet-E	Serial-011
12	Subnet-E	Serial-012
13	Subnet-F	Serial-013	x
14	Subnet-F	Serial-014
15	Subnet-F	Serial-015
16
Sheet1

Excel 2007
	A
1	Serial-001
2	Serial-004
3	Serial-007
4	Serial-009
5	Serial-010
6	Serial-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.

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.

 

[VBA Clueless]

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.

 

[VBA Clueless]

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!

 

[hiker95]

VBA Clueless,

Your solution worked great! Thank you for your help!

Thanks for the feedback.

You are very welcome. Glad I could help.

 

[hiker95]

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.

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
	A	B	C
1	Subnet-A	Serial-001	x
2	Subnet-A	Serial-002
3	Subnet-A	Serial-003
4	Subnet-B	Serial-004	x
5	Subnet-B	Serial-005
6	Subnet-B	Serial-006
7	Subnet-C	Serial-007	x
8	Subnet-C	Serial-008
9	Subnet-D	Serial-009	x
10	Subnet-E	Serial-010	x
11	Subnet-E	Serial-011
12	Subnet-E	Serial-012
13	Subnet-F	Serial-013	x
14	Subnet-F	Serial-014
15	Subnet-F	Serial-015
16
Sheet1

Excel 2007
	A
1	Serial-001
2	Serial-004
3	Serial-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.

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.

 

[VBA Clueless]

You Rock! Thanks again for a great solution!

 

[hiker95]

VBA Clueless,

Thanks for the feedback.

You are very welcome again. Glad I could help.

And, come back anytime.