I have sets of data in excel which is to be arrange or transpose the row data after every blank in column A.
I got a code before and its actually perfect. The problem is that it will only search numbers in a column but if the cell is with letters the code will have an error.
Example 1: Column A with numbers only (OKAY)
Sheet1:
enter image description here
Sheet2: RESULT PERFECT
enter image description here
Example 2: Column A with letters and numbers (NOW WITH ERROR)
Sheet1:
enter image description here
ERROR Message:
enter image description here
And this is the code that needs revision that can bear both letters and numbers.
Sub Arrange()
Dim mA As Long, nA As Long, mB As Long, nB As Long, idx As Long
Dim eRow As Long, eCol As Long
Dim LastCell As Range
Dim wsA As Worksheet, wsB As Worksheet
Set wsA = ActiveWorkbook.Sheets("Sheet1")
Set wsB = ActiveWorkbook.Sheets("Sheet2")
Set LastCell = wsA.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious)
eRow = LastCell.Row
eCol = LastCell.Column
For mA = 1 To eRow
If Not wsA.Cells(mA, 1) = 0 Then
idx = wsA.Cells(mA, 1)
nB = 0
End If
For nA = 1 To eCol
If Not mB = idx Then mB = mB + 1
If Not Len(wsA.Cells(mA, nA)) = 0 Then
If mB = idx Then nB = nB + 1
wsB.Cells(mB, nB) = wsA.Cells(mA, nA)
End If
Next
Next
End Sub
Thanks!
2
Transform Data
Source
Destination
Sub ArrangeData()
' Reference the workbook.
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
' Reference the source objects.
Dim sws As Worksheet: Set sws = wb.Sheets("Sheet1")
Dim lcell As Range
Set lcell = sws.Cells.Find("*", , xlFormulas, , xlByRows, xlPrevious)
If lcell Is Nothing Then Exit Sub
Dim sRowsCount As Long: sRowsCount = lcell.Row
Set lcell = sws.Cells.Find("*", , xlFormulas, , xlByColumns, xlPrevious)
Dim sColsCount As Long: sColsCount = lcell.Column
If sColsCount < 2 Then Exit Sub
Dim srg As Range: Set srg = sws.Range("A1").Resize(sRowsCount, sColsCount)
' Return the values from the source range in an array.
Dim sData As Variant: sData = srg.Value
' Reference a new dictionary object.
Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
' Loop through the elements in the array and apply the logic...
Dim Item As Variant, sRow As Long, sCol As Long, dRow As Long, dCol As Long
For sRow = 1 To sRowsCount
Item = sData(sRow, 1)
If Len(CStr(Item)) > 0 Then
dRow = dRow + 1
dCol = 1
Set dict(dRow) = CreateObject("Scripting.Dictionary")
dict(dRow)(dCol) = Item
End If
For sCol = 2 To sColsCount
Item = sData(sRow, sCol)
If Len(CStr(Item)) > 0 Then
dCol = dCol + 1
dict(dRow)(dCol) = Item
End If
Next sCol
Next sRow
If dict.Count = 0 Then Exit Sub ' all values were blank
' Copy data.
' Reference the destination objects.
Dim dws As Worksheet: Set dws = wb.Sheets("Sheet2")
Dim dcell As Range: Set dcell = dws.Range("A1")
' Clear existing data.
With dcell
.Resize(dws.Rows.Count - .Row + 1, dws.Columns.Count - .Column + 1) _
.Clear
End With
' Copy new data.
For Each Item In dict.Items
dcell.Resize(, Item.Count).Value = Item.Items
Set dcell = dcell.Offset(1)
Next Item
MsgBox "Data arranged.", vbInformation
End Sub
1