VBA Code - Change Input Box to Specific Range

[DEE_715]

Hi,

I recently came accross a VBA code to 'Transpose cells in one column based on unique values' (Below).
It works perfectly and is exactly what I need however I can't fugure out how to get it to work based on specfic pre-determined ranges rather than using the input box;
i.e. xRg = "A1:B10" and xOutRg = "C1"

I would really appreciate it if someone could help with this.

Many Thanks in advance
David

Sub transposeunique()
updateby Extendoffice
    Dim xLRow As Long
    Dim i As Long
    Dim xCrit As String
    Dim xCol  As New Collection
    Dim xRg As Range
    Dim xOutRg As Range
    Dim xTxt As String
    Dim xCount As Long
    Dim xVRg As Range
    On Error Resume Next
    xTxt = ActiveWindow.RangeSelection.Address
    Set xRg = Application.InputBox("please select data range(only two columns):", "Kutools for Excel", xTxt, , , , , 8)
    Set xRg = Application.Intersect(xRg, xRg.Worksheet.UsedRange)
    If xRg Is Nothing Then Exit Sub
    If (xRg.Columns.Count <> 2) Or _
       (xRg.Areas.Count > 1) Then
        MsgBox "the used range is only one area with two columns ", , "Kutools for Excel"
        Exit Sub
    End If
    Set xOutRg = Application.InputBox("please select output range(specify one cell):", "Kutools for Excel", xTxt, , , , , 8)
    If xOutRg Is Nothing Then Exit Sub
    Set xOutRg = xOutRg.Range(1)
    xLRow = xRg.Rows.Count
    For i = 2 To xLRow
        xCol.Add xRg.Cells(i, 1).Value, xRg.Cells(i, 1).Value
    Next
    Application.ScreenUpdating = False
    For i = 1 To xCol.Count
        xCrit = xCol.Item(i)
        xOutRg.Offset(i, 0) = xCrit
        xRg.AutoFilter Field:=1, Criteria1:=xCrit
        Set xVRg = xRg.Range("B2:B" & xLRow).SpecialCells(xlCellTypeVisible)
        If xVRg.Count > xCount Then xCount = xVRg.Count
        xRg.Range("B2:B" & xLRow).SpecialCells(xlCellTypeVisible).Copy
        xOutRg.Offset(i, 1).PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
        Application.CutCopyMode = False
    Next
    xOutRg = xRg.Cells(1, 1)
    xOutRg.Offset(0, 1).Resize(1, xCount) = xRg.Cells(1, 2)
    xRg.Rows(1).Copy
    xOutRg.Resize(1, xCount + 1).PasteSpecial Paste:=xlPasteFormats
    xRg.AutoFilter
    Application.ScreenUpdating = True
End Sub

 

[Logit]

Set xRg = Range("A1:B10")

Set xOutRg = Range("C1")

Untested here :


Sub transposeunique() Dim xLRow As Long Dim i As Long Dim xCrit As String Dim xCol As New Collection Dim xRg As Range Dim xOutRg As Range Dim xTxt As String Dim xCount As Long Dim xVRg As Range On Error Resume Next xTxt = ActiveWindow.RangeSelection.Address Set xRg = Range("A1:B10") 'Set xRg = Application.Intersect(xRg, xRg.Worksheet.UsedRange) If xRg Is Nothing Then Exit Sub If (xRg.Columns.Count <> 2) Or _ (xRg.Areas.Count > 1) Then MsgBox "the used range is only one area with two columns ", , "Kutools for Excel" Exit Sub End If 'Set xOutRg = Application.InputBox("please select output range(specify one cell):", "Kutools for Excel", xTxt, , , , , 8) Set xOutRg = Range("C1") If xOutRg Is Nothing Then Exit Sub Set xOutRg = xOutRg.Range(1) xLRow = xRg.Rows.Count For i = 2 To xLRow xCol.Add xRg.Cells(i, 1).Value, xRg.Cells(i, 1).Value Next Application.ScreenUpdating = False For i = 1 To xCol.Count xCrit = xCol.Item(i) xOutRg.Offset(i, 0) = xCrit xRg.AutoFilter Field:=1, Criteria1:=xCrit Set xVRg = xRg.Range("B2:B" & xLRow).SpecialCells(xlCellTypeVisible) If xVRg.Count > xCount Then xCount = xVRg.Count xRg.Range("B2:B" & xLRow).SpecialCells(xlCellTypeVisible).Copy xOutRg.Offset(i, 1).PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=True Application.CutCopyMode = False Next xOutRg = xRg.Cells(1, 1) xOutRg.Offset(0, 1).Resize(1, xCount) = xRg.Cells(1, 2) xRg.Rows(1).Copy xOutRg.Resize(1, xCount + 1).PasteSpecial Paste:=xlPasteFormats xRg.AutoFilter Application.ScreenUpdating = True End Sub

 

[DEE_715]

Hi Logit, many thanks for your reply; your solution works perfectly.

If i could trouble you with one more samll query; the above code works perfectly as long as the info in the "A" (unique values) column is text but it doest work where its numerical data, is there a simple change i can make to adjust for when the unique data numerical? (See below Example)

Sorry for the hassle, its been a long time since i've worked with VBA

Kind Regards
David