Unique Values and Double Values in Excel VBA

[kate.middleton]

Hello Everybody,

I have an Input Values something like this,

Input Output 1 1 1 1 2 Empty Row 3 2 3 Empty Row 3 3 4 3 3 Empty Row 4 I want output like this using VBA. <colgroup><col style="width:60pt" width="80"> <col style="width:60pt" span="2" width="80"> <col style="width:60pt" width="80"> </colgroup><tbody> </tbody>

<tbody>
</tbody>

 

[Comfy]

Select your values and run this:

Sub AddBlankRow()
Dim rng As Range
Dim rCell As Range
Dim i As Long
Dim NewCount As Long


Set rng = Selection
i = rng.Row
If rng.Columns.Count > 1 Then MsgBox "Too many columns have been selected, this will terminate.": Exit Sub


For Each rCell In rng
    If LCase(rCell.Offset(-1, 0).Value) = "input" Or rCell.Offset(-1, 0).Value = rCell.Value Then
        Cells(i, rng.Column + 2).Value = rCell.Value
        i = i + 1
    Else
        Cells(i, rng.Column + 2).Value = ""
        Cells(i + 1, rng.Column + 2).Value = rCell.Value
        i = i + 2
    End If
Next rCell


End Sub

 

[kate.middleton]

Hello,
Thanks for your reply. This macro is not producing the same Output as desired.
Actually i want that if the Cells value in Input Column Changes then it make the Empty cell in Output Column.

 

[Comfy]

Hello,
Thanks for your reply. This macro is not producing the same Output as desired.
Actually i want that if the Cells value in Input Column Changes then it make the Empty cell in Output Column.

I don't understand what you are asking.

Please provide an example of the before and after.

 

[kate.middleton]

Input Data
1
1
2
2
3
3
3
3
4
5
6
When i run the Macro the Output should come like this, <tbody> </tbody>
Output Data
1
1
Empty cell
2
2
Empty cell
3
3
3
3
Empty cell
4
Empty cell
5
Empty cell
6

<tbody>
</tbody>

 

[Comfy]

The macro I posted does this.

Select you Input Data, don't include the header and run the macro.

The output will appear two columns to the right with a space between each changing value.

 

[MickG]

Just another option !!!

[COLOR="Navy"]Sub[/COLOR] MG22Sep36
[COLOR="Navy"]Dim[/COLOR] Rng [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]Dim[/COLOR] n [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]Dim[/COLOR] Lst [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Integer[/COLOR]
Lst = Range("A" & Rows.Count).End(xlUp).Row
[COLOR="Navy"]Set[/COLOR] Rng = Range(Range("A2"), Range("A" & Rows.Count).End(xlUp))
Rng.Offset(, 2).Value = Rng.Value
[COLOR="Navy"]For[/COLOR] n = Lst To 3 [COLOR="Navy"]Step[/COLOR] -1
    [COLOR="Navy"]With[/COLOR] Range("C" & n)
        [COLOR="Navy"]If[/COLOR] Not .Offset(-1).Value = .Value [COLOR="Navy"]Then[/COLOR] .Insert shift:=xlDown
    [COLOR="Navy"]End[/COLOR] With
[COLOR="Navy"]Next[/COLOR] n
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]

Regards Mick

 

[kate.middleton]

Thanks for your reply.Is it also possible with arrays??

 

[MickG]

Try this:-

[COLOR="Navy"]Sub[/COLOR] MG22Sep27
[COLOR="Navy"]Dim[/COLOR] n       [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]Dim[/COLOR] c       [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]Dim[/COLOR] Ray
[COLOR="Navy"]Dim[/COLOR] Lst     [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Integer[/COLOR]
[COLOR="Navy"]Dim[/COLOR] Nn      [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]Dim[/COLOR] Temp    [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]String[/COLOR]
Ray = Application.Transpose(Range(Range("A2"), Range("A" & Rows.Count).End(xlUp)))
ReDim Preserve Ray(1 To UBound(Ray) * 2)
[COLOR="Navy"]For[/COLOR] n = UBound(Ray) To 2 [COLOR="Navy"]Step[/COLOR] -1
    [COLOR="Navy"]If[/COLOR] Not Ray(n) = Ray(n - 1) [COLOR="Navy"]Then[/COLOR]
        [COLOR="Navy"]For[/COLOR] Nn = n To UBound(Ray) - 1
            Temp = Ray(Nn + 1)
            Ray(Nn + 1) = Ray(n)
            Ray(n) = Temp
        [COLOR="Navy"]Next[/COLOR] Nn
[COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]Next[/COLOR] n
Range("C2").Resize(UBound(Ray)).Value = Application.Transpose(Ray)
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]

Regards Mick

 

[hiker95]

kate.middleton,

The following macro uses two arrays in memory.

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

Sub ReorgData()
' hiker95, 09/22/2014, ME806965
Dim a As Variant, o As Variant
Dim i As Long, j As Long, lr As Long
lr = Cells(Rows.Count, 1).End(xlUp).Row
a = Range("A1:A" & lr)
ReDim o(1 To lr * 2, 1 To 1)
For i = 2 To lr Step 1
  If a(i, 1) = a(i - 1, 1) Then
    j = j + 1
    o(j, 1) = a(i, 1)
  ElseIf a(i, 1) <> a(i - 1, 1) Then
    j = j + 1
    o(j, 1) = a(i - 1, 1)
    j = j + 1
  End If
Next i
j = j + 1
o(j, 1) = a(lr, 1)
Cells(1, 3).Resize(lr * 2, 1).Value = o
End Sub

Before you use the macro with Excel 2007 or newer, save your workbook, Save As, a macro enabled workbook with the file extension .xlsm

Then run the ReorgData macro.