VBA Transpose Cells Based On Unique Values

[roykana]

Dear All master,

Please help with vba code, I want input range with inputbox and output range with inputbox.

The data is on the db sheet in column E & F which I marked in yellow and the results

I want are in the results sheet in columns A, B, C. I want a very fast vba code because the data records are thousands.

This is my link : VBA Transpose Cells Based On Unique Values.xlsm
file

Thanks

roykana

 

[roykana]

I'm not sure what you mean by this statement. Are you saying that only for those ID numbers shown in column A in the screenshot, the corresponding cells in column C should be blank?

Dear mr. mumps
What I mean is if on sheet "db" with one id and with one status, then in sheet "result" it will appear in column a which is ID, column b is status and column c is blank. for example ID 100243669 on line 98 has one status, which is "normal" but the results in the sheet "results" with macros are a2: 100243669, b2: NORMAL, c2: NORMAL should C2 be blank and ID 501143617 on lines 8392 & 8393 has two states, namely "not fixed" but the results in the sheet "result" with macros are a4734: 501143617, b4734: not fixed, c4734: blank should be C4734 is not fixed.

I also attached an excel file with which I compare the macro results with the manual results. You can see in column k with the correct manual result status.

This my link : VBA Transpose Cells Based On Unique Values-2.xlsm
file
thanks
roykana

 

[roykana]

What do you mean by "other data"? Please give an example. Will the cells that currently contain the text "NORMAL" always have the same value and if so, what is that value?

I mean not only used for dual "normal" status so it can be used for other dual statuses. I gave a sample screenshot.

 

[roykana]

Do you want to select the input and output ranges?

I want to input range with input box application so I specify the range directly to sheet "db" and for output range with input box application so I specify the range directly to sheet "results"

 

[roykana]

Please explain what you mean by this.

I mean for my post this progress is 80% of the code you provide

 

[mumps]

Before we go any further, try this macro. It should be very fast but make sure that all the data on the RESULT sheet is correct after running it.

Sub CopyUniques()
     With Application
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
        .EnableEvents = False
     End With
    Dim arr As Variant
    Dim i As Long, srcWS As Worksheet, desWS As Worksheet, dic1 As Object, x As Long: x = 2
    Dim startTime As Single, endTime As Single
    startTime = timer
    Set srcWS = Sheets("DB")
    Set desWS = Sheets("RESULT")
    arr = srcWS.Range("E7", srcWS.Range("E7").End(xlDown)).Resize(, 2).Value
    Set dic1 = CreateObject("Scripting.Dictionary")
    For i = LBound(arr) To UBound(arr)
        If Not dic1.exists(arr(i, 1)) Then
            dic1.Add Key:=arr(i, 1), Item:=arr(i, 2)
        End If
    Next i
    desWS.Range("A2").Resize(dic1.Count, 2).Value = Application.Transpose(Array(dic1.keys, dic1.items))
    dic1.RemoveAll
    For i = LBound(arr) To UBound(arr)
        If i <= UBound(arr) - 1 Then
            If arr(i, 1) <> arr(i + 1, 1) Then
                If Not dic1.exists(arr(i, 1)) Then
                    dic1.Add Key:=arr(i, 1), Item:="x"
                End If
            Else
                If Not dic1.exists(arr(i, 1)) Then
                    dic1.Add Key:=arr(i, 1), Item:=arr(i + 1, 2)
                End If
            End If
        End If
    Next i
    desWS.Range("C2").Resize(dic1.Count).Value = Application.Transpose(dic1.items)
    desWS.Columns("C").Replace "x", "", xlWhole, , False
    With Application
        .EnableEvents = True
        .Calculation = xlCalculationAutomatic
        .ScreenUpdating = True
    End With
    endTime = timer
    Debug.Print Format((endTime - startTime) / 86400, "hh:mm:ss") & " seconds have passed [VBA]"
End Sub

 

[roykana]

Before we go any further, try this macro. It should be very fast but make sure that all the data on the RESULT sheet is correct after running it.

Sub CopyUniques()
     With Application
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
        .EnableEvents = False
     End With
    Dim arr As Variant
    Dim i As Long, srcWS As Worksheet, desWS As Worksheet, dic1 As Object, x As Long: x = 2
    Dim startTime As Single, endTime As Single
    startTime = timer
    Set srcWS = Sheets("DB")
    Set desWS = Sheets("RESULT")
    arr = srcWS.Range("E7", srcWS.Range("E7").End(xlDown)).Resize(, 2).Value
    Set dic1 = CreateObject("Scripting.Dictionary")
    For i = LBound(arr) To UBound(arr)
        If Not dic1.exists(arr(i, 1)) Then
            dic1.Add Key:=arr(i, 1), Item:=arr(i, 2)
        End If
    Next i
    desWS.Range("A2").Resize(dic1.Count, 2).Value = Application.Transpose(Array(dic1.keys, dic1.items))
    dic1.RemoveAll
    For i = LBound(arr) To UBound(arr)
        If i <= UBound(arr) - 1 Then
            If arr(i, 1) <> arr(i + 1, 1) Then
                If Not dic1.exists(arr(i, 1)) Then
                    dic1.Add Key:=arr(i, 1), Item:="x"
                End If
            Else
                If Not dic1.exists(arr(i, 1)) Then
                    dic1.Add Key:=arr(i, 1), Item:=arr(i + 1, 2)
                End If
            End If
        End If
    Next i
    desWS.Range("C2").Resize(dic1.Count).Value = Application.Transpose(dic1.items)
    desWS.Columns("C").Replace "x", "", xlWhole, , False
    With Application
        .EnableEvents = True
        .Calculation = xlCalculationAutomatic
        .ScreenUpdating = True
    End With
    endTime = timer
    Debug.Print Format((endTime - startTime) / 86400, "hh:mm:ss") & " seconds have passed [VBA]"
End Sub

Dear Mr. mumps,

Thank you very much. the code you provide works perfectly and very fast.

one more I want to input range with input box application so I specify the range directly to sheet "db" and for output range with input box application so I specify the range directly to sheet "results".

Thanks
roykana

 

[mumps]

For clarification:
Could you please give me an example of what you want to do referring to specific cells, rows, columns and sheets. For example, select E20:E100 in DB as the input range and the select A8 in RESULT as the output range. This would process ID 100243629 to ID 100243670.

 

[roykana]

For clarification:
Could you please give me an example of what you want to do referring to specific cells, rows, columns and sheets. For example, select E20:E100 in DB as the input range and the select A8 in RESULT as the output range. This would process ID 100243629 to ID 100243670.

Dear mr. mumps
the example you gave is correct.

the process is the same. the process was the same before. The difference is we choose our own input range in the input box application and the output range in the input box application.


Thanks

roykana

 

[roykana]

For clarification:
Could you please give me an example of what you want to do referring to specific cells, rows, columns and sheets. For example, select E20:E100 in DB as the input range and the select A8 in RESULT as the output range. This would process ID 100243629 to ID 100243670.

Dear mr. mumps
the example you gave is correct.

the process is the same. the process was the same before. The difference is we choose our own input range in the input box application and the output range in the input box application.


Thanks

roykana

Dear mr. mumps
the example you gave is correct.

the process is the same. the process was the same before. The difference is we choose our own input range in the input box application and the output range in the input box application.


Thanks

roykana

so our input and output ranges define ourselves

 

[mumps]

When you run the macro, please follow the instructions in the prompts very carefully.

Option Explicit
Sub CopyUniques()
    Dim lRow As Long, arr As Variant, i As Long, srcWS As Worksheet, desWS As Worksheet, dic As Object, inRng As Range, outRng As Range, x As Long: x = 2
    Sheets("DB").Activate
    Set inRng = Application.InputBox("Select a range of ID's in column E.", Type:=8)
    Sheets("RESULT").Activate
    Columns("A:C").ClearContents
    Set outRng = Application.InputBox("Select a single cell in column A.", Type:=8)
    With Application
       .ScreenUpdating = False
       .Calculation = xlCalculationManual
       .EnableEvents = False
    End With
    Set srcWS = Sheets("DB")
    Set desWS = Sheets("RESULT")
    arr = inRng.Cells(1).Resize(inRng.Rows.Count, 2).Value
    Set dic = CreateObject("Scripting.Dictionary")
    For i = LBound(arr) To UBound(arr)
        If Not dic.exists(arr(i, 1)) Then
            dic.Add Key:=arr(i, 1), Item:=arr(i, 2)
        End If
    Next i
    outRng.Resize(dic.Count, 2).Value = Application.Transpose(Array(dic.keys, dic.items))
    dic.RemoveAll
    For i = LBound(arr) To UBound(arr)
        If i <= UBound(arr) - 1 Then
            If arr(i, 1) <> arr(i + 1, 1) Then
                If Not dic.exists(arr(i, 1)) Then
                    dic.Add Key:=arr(i, 1), Item:="x"
                End If
            Else
                If Not dic.exists(arr(i, 1)) Then
                    dic.Add Key:=arr(i, 1), Item:=arr(i + 1, 2)
                End If
            End If
        Else
            If Not dic.exists(arr(i, 1)) Then
                dic.Add Key:=arr(i, 1), Item:="x"
            Else
                dic.Item(arr(i, 1)) = arr(i, 2)
            End If
        End If
    Next i
    outRng.Offset(, 2).Resize(dic.Count).Value = Application.Transpose(dic.items)
    desWS.Columns("C").Replace "x", "", xlWhole, , False
    With Application
        .EnableEvents = True
        .Calculation = xlCalculationAutomatic
        .ScreenUpdating = True
    End With
End Sub