Suppose that we have a column including a million rows of texts and numbers sorting irregularly like this:
h
d
s
23
c
45
33
s
n
98
As it shown every number value has some texts value in upper rows of it till the next number value. Is there any VBA to sort it in two columns like this?
23 h
23 d
23 s
45 c
98 s
98 n
Any help would be appreciated.
Looping through that many cells will likely be extremely slow
Sub FindNumbersText()
Dim rCl As Range, rData As Range
Dim lRw As Long
Set rData = Range("A1").CurrentRegion.Columns(1)
For Each rCl In rData.Cells
If Application.WorksheetFunction.IsNumber(rCl.Value) Then
lRw = Cells(Rows.Count, 3).End(xlUp).Row + 1
Cells(lRw, 3).Value = rCl.Value
Else:
lRw = Cells(Rows.Count, 4).End(xlUp).Row + 1
Cells(lRw, 4).Value = rCl.Value
End If
Next rCl
End SubHi to all.
This is what I came up with, have a try. Paste it wherever you prefer but it has no reference to a specific sheet so, as it is, it works on the activesheet:
Option Explicit
Sub CombineNumbersAndText()
Dim lr As Long
Dim x As Long
Dim num As Long
Application.ScreenUpdating = False
lr = Range("A" & Rows.Count).End(xlUp).Row
For x = lr To 2 Step -1
If Application.IsNumber(Cells(x, 1).Value) Then
num = Cells(x, 1)
If Application.IsNumber(Cells(x - 1, 1).Value) Then GoTo skip
Range("C1:D1").Insert Shift:=xlDown 'insert cells by shifting down
Cells(1, 3) = num 'paste in column C
Cells(1, 4) = Cells(x - 1, 1).Value 'paste in column D
ElseIf Not Application.IsNumber(Cells(x - 1, 1).Value) Then
Range("C1:D1").Insert Shift:=xlDown 'insert cells by shifting down
Cells(1, 3) = num 'paste in column C
Cells(1, 4) = Cells(x - 1, 1).Value 'paste in column D
End If
skip:
Next x
Application.ScreenUpdating = True
End SubTry the attached, it will be faster (especially with a large data set). Click the button on the sheet.
Code assigned to the button
Sub CombineTextAndNumber()
Dim x, y, i As Long, ii As Long, oDic As Object
Set oDic = CreateObject("scripting.dictionary")
With ActiveSheet
x = .Cells(1).CurrentRegion
For i = UBound(x, 1) To 1 Step -1
If IsNumeric(x(i, 1)) Then
ii = i - 1
Do Until IsNumeric(x(ii, 1))
oDic.Add oDic.Count, x(i, 1) & " " & x(ii, 1)
ii = ii - 1
If ii < 1 Then Exit For
Loop
i = ii + 1
End If
Next
ReDim y(1 To oDic.Count, 1 To 2)
ii = 0
For i = oDic.Count - 1 To 0 Step -1
ii = i + 1
y(ii, 1) = Split(oDic(i))(0)
y(ii, 2) = Split(oDic(i))(1)
Next
With .[c1]
.Resize(100000, 2).Clear
.Resize(UBound(y), 2) = y
.Resize(UBound(y), 2).HorizontalAlignment = -4108
End With
End With
End SubThanks a lot, it works great. You're a genius.
You're welcome
An alternative to VBA is Power Query. Here is the Mcode and file attached.
let
Source = Excel.CurrentWorkbook(){[Name="Table1"]}[Content],
#"Added Custom" = Table.AddColumn(Source, "Custom", each try Number.From([Column1]) is number otherwise null),
#"Added Custom1" = Table.AddColumn(#"Added Custom", "Custom.1", each if [Custom] = true then [Column1] else null),
#"Filled Up" = Table.FillUp(#"Added Custom1",{"Custom.1"}),
#"Filtered Rows" = Table.SelectRows(#"Filled Up", each ([Custom] = null)),
#"Removed Columns" = Table.RemoveColumns(#"Filtered Rows",{"Custom"})
in
#"Removed Columns"If you can do it in a Power Query and the table layout is acceptable the Power Query is exceptionally fast!
Agreed, if it works for you then Power Query is the way to go
Don’t have an account yet? Register yourself now and be a part of our community!