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

 

[mumps]

It would be easier to help if you could use the XL2BB add-in (icon in the menu) to attach a screenshot (not a picture) of your sheets. Alternately, you could upload a copy of your file to a free site such as www.box.com or www.dropbox.com. Once you do that, mark it for 'Sharing' and you will be given a link to the file that you can post here. Explain in detail what you want to do referring to specific cells, rows, columns and sheets using a few examples from your data (de-sensitized if necessary).

 

[roykana]

It would be easier to help if you could use the XL2BB add-in (icon in the menu) to attach a screenshot (not a picture) of your sheets. Alternately, you could upload a copy of your file to a free site such as www.box.com or www.dropbox.com. Once you do that, mark it for 'Sharing' and you will be given a link to the file that you can post here. Explain in detail what you want to do referring to specific cells, rows, columns and sheets using a few examples from your data (de-sensitized if necessary).

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

 

[roykana]

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

I want input range with inputbox and output range with inputbox then
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. Which I marked in yellow. I want a very fast vba code because the data records are thousands.

 

[mumps]

Please explain in more detail what you are trying to do. For example, in row 10, columns E and F of DB you have 1002243619 and PULANG AWAL. In row 21, columns E and F of DB you have 1002243630 and S ( Sakit ). In row 3, columns B and C of RESULT you have NORMAL and PULANG AWAL. In row 9, columns B and C of RESULT you have S ( Sakit ) and a blank cell. Can you explain why column B has the name in row 3 and a blank cell in row 9?

 

[roykana]

Please explain in more detail what you are trying to do. For example, in row 10, columns E and F of DB you have 1002243619 and PULANG AWAL. In row 21, columns E and F of DB you have 1002243630 and S ( Sakit ). In row 3, columns B and C of RESULT you have NORMAL and PULANG AWAL. In row 9, columns B and C of RESULT you have S ( Sakit ) and a blank cell. Can you explain why column B has the name in row 3 and a blank cell in row 9?

1002243619 This is the combination of employee number with date and status for attendance entry and return. For the combination of 1002243619 in lines 9 and 10 it produces 2 statuses, namely NORMAL and PULANG AWAL. One date has 2 time records, namely the time of entry and time of return. So when the status enters "NORMAL" and when the status comes "PULANG AWAL" so this is the answer for the db sheet in line 3. For the combination 100243630 only has one record because the employee is not present, the status is " S ( Sakit )" so in the result sheet on line 9 it will be only appears 1 status. So the point is if one combination has more than one status then the result is in column B & C AND if one combination has one status then the result is in column B only. Additional points if the result sheet in column B & C contains the same status, then I want only status B to be filled in.
for my explanation whether you understand because I want to rest first

 

[roykana]

1002243619 This is the combination of employee number with date and status for attendance entry and return. For the combination of 1002243619 in lines 9 and 10 it produces 2 statuses, namely NORMAL and PULANG AWAL. One date has 2 time records, namely the time of entry and time of return. So when the status enters "NORMAL" and when the status comes "PULANG AWAL" so this is the answer for the db sheet in line 3. For the combination 100243630 only has one record because the employee is not present, the status is " S ( Sakit )" so in the result sheet on line 9 it will be only appears 1 status. So the point is if one combination has more than one status then the result is in column B & C AND if one combination has one status then the result is in column B only. Additional points if the result sheet in column B & C contains the same status, then I want only status B to be filled in.
for my explanation whether you understand because I want to rest first

Dear Mr. mumps
can you help me for the vba code?

Thanks
Roykana

 

[mumps]

Try this macro. On my machine, it took 2 minutes and 8 seconds to run. It may take less or more time on your machine depending on its processor speed so be patient. There may be a faster way to do this, but I struggled to find one.

Sub CopyUniques()
    Application.ScreenUpdating = False
    Dim arr As Variant
    Dim i As Long, srcWS As Worksheet, desWS As Worksheet, dic1 As Object, x As Long: x = 2
    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
    StartTime = Timer
    For i = LBound(arr) To UBound(arr)
        If WorksheetFunction.CountIf(srcWS.Range("E:E"), arr(i, 1)) = 1 Then
            dic1.Add Key:=arr(i, 1), Item:=arr(i, 2)
        Else
            If Not dic1.exists(arr(i, 1)) Then
                dic1.Add Key:=arr(i, 1), Item:=arr(i + 1, 2)
            End If
        End If
    Next i
    desWS.Range("C2").Resize(dic1.Count).Value = Application.Transpose(dic1.items)
    dic1.RemoveAll
    arr = desWS.Range("A2", desWS.Range("A2").End(xlDown)).Resize(, 3).Value
    For i = LBound(arr) To UBound(arr)
        If arr(i, 2) = arr(i, 3) And arr(i, 3) <> "NORMAL" Then
            desWS.Cells(x, 3) = "x"
            x = x + 1
        Else
            desWS.Cells(x, 3) = arr(i, 3)
            x = x + 1
        End If
    Next i
    desWS.Columns("C").Replace "x", "", xlWhole, , False
    Application.ScreenUpdating = True
End Sub

 

[roykana]

Try this macro. On my machine, it took 2 minutes and 8 seconds to run. It may take less or more time on your machine depending on its processor speed so be patient. There may be a faster way to do this, but I struggled to find one.

[CODE=vba]Sub CopyUniques()
    Application.ScreenUpdating = False
    Dim arr As Variant
    Dim i As Long, srcWS As Worksheet, desWS As Worksheet, dic1 As Object, x As Long: x = 2
    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
    StartTime = Timer
    For i = LBound(arr) To UBound(arr)
        If WorksheetFunction.CountIf(srcWS.Range("E:E"), arr(i, 1)) = 1 Then
            dic1.Add Key:=arr(i, 1), Item:=arr(i, 2)
        Else
            If Not dic1.exists(arr(i, 1)) Then
                dic1.Add Key:=arr(i, 1), Item:=arr(i + 1, 2)
            End If
        End If
    Next i
    desWS.Range("C2").Resize(dic1.Count).Value = Application.Transpose(dic1.items)
    dic1.RemoveAll
    arr = desWS.Range("A2", desWS.Range("A2").End(xlDown)).Resize(, 3).Value
    For i = LBound(arr) To UBound(arr)
        If arr(i, 2) = arr(i, 3) And arr(i, 3) <> "NORMAL" Then
            desWS.Cells(x, 3) = "x"
            x = x + 1
        Else
            desWS.Cells(x, 3) = arr(i, 3)
            x = x + 1
        End If
    Next i
    desWS.Columns("C").Replace "x", "", xlWhole, , False
    Application.ScreenUpdating = True
End Sub

[/CODE]

Dear mr. mumps

thank you for your reply.
you are indeed my best teacher.
after I tried there was a little problem in the code "startTime = timer" but I fixed it. and also I added the code to speed up the process. The problem is as follows:
1. The problem I attach some of the problems in the form of screenshots. The status of the source is one so the result should be one.
2. I see in the code there is the word "normal". What is modified so that there is no word "normal:" so that it can be used for other data.
3. I want the input range ("DB") and the output range ("result") to use Application.InputBox.
percent progress is already 80%.
thanks
roykana

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 WorksheetFunction.CountIf(srcWS.Range("E:E"), arr(i, 1)) = 1 Then
            dic1.Add Key:=arr(i, 1), Item:=arr(i, 2)
        Else
            If Not dic1.exists(arr(i, 1)) Then
                dic1.Add Key:=arr(i, 1), Item:=arr(i + 1, 2)
            End If
        End If
    Next i
    desWS.Range("C2").Resize(dic1.Count).Value = Application.Transpose(dic1.items)
    dic1.RemoveAll
    arr = desWS.Range("A2", desWS.Range("A2").End(xlDown)).Resize(, 3).Value
    For i = LBound(arr) To UBound(arr)
        If arr(i, 2) = arr(i, 3) And arr(i, 3) <> "NORMAL" Then
            desWS.Cells(x, 3) = "x"
            x = x + 1
        Else
            desWS.Cells(x, 3) = arr(i, 3)
            x = x + 1
        End If
    Next i
    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

 

[mumps]

The status of the source is one so the result should be one.

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?

I see in the code there is the word "normal". What is modified so that there is no word "normal:" so that it can be used for other data.

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 want the input range ("DB") and the output range ("result") to use Application.InputBox.

Do you want to select the input and output ranges?

percent progress is already 80%.

Please explain what you mean by this.