VBA Transpose Cells Based On Unique Values

roykana

Active Member
Joined
Mar 8, 2018
Messages
311
Office Version
  1. 2010
Platform
  1. Windows
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
 

Attachments

  • data.JPG
    data.JPG
    89.1 KB · Views: 58
  • result.JPG
    result.JPG
    23.5 KB · Views: 57

Excel Facts

How to find 2nd largest value in a column?
MAX finds the largest value. =LARGE(A:A,2) will find the second largest. =SMALL(A:A,3) will find the third smallest
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).
 
Upvote 0
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
 
Upvote 0
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.
 
Upvote 0
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?
 
Upvote 0
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
 
Upvote 0
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
 
Upvote 0
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.
VBA Code:
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
 
Upvote 0
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.
VBA Code:
[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
VBA Code:
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
 

Attachments

  • Capture 09-12-2020.JPG
    Capture 09-12-2020.JPG
    40.1 KB · Views: 16
  • Capture 09-12-2020-02.JPG
    Capture 09-12-2020-02.JPG
    11.8 KB · Views: 16
Upvote 0
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.
 
Upvote 0

Forum statistics

Threads
1,224,820
Messages
6,181,159
Members
453,021
Latest member
Justyna P

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