How can I find a numeric number in the same cell after character. For ex After J* find number 01. I will have few rows and inside row some value will J*01 or J*08 im trying separate between character and number using instar in VBA:
Sub zz()
Dim ii As Long, z As Integer, xlastrow As Long
Dim yy As String
xlastrow = Worksheets("Sheet1").UsedRange.Rows.Count
For ii = 1 To xlastrow
yy = "J*"
z = 1
If IsNumeric(Worksheets("Sheet1").Range("B" & ii)) Then
This line separating number after J* character and pasting it to sheet2
Seprate.Find.Range("B" & ii, yy).Value = Worksheet("Sheet2").Range("A" & z)
End If
z = z + 1
Next ii
End Sub
Please try this code
' paste the values in column A.
q1w2e3r4asJ*66bvft654
1234BA
BA1234BA
xuz12354
''''' Code
Option Explicit
Sub Remove_Charecter()
Dim Last_Row As Double
Dim num As Double
Dim i As Integer
Dim j As Integer
Last_Row = Range("A65536").End(xlUp).Row
For i = 1 To Last_Row
num = 0
For j = 1 To Len(Cells(i, 1))
If IsNumeric(Mid(Cells(i, 1), j, 1)) Then
num = Trim(num & Mid(Cells(i, 1), j, 1))
End If
Next j
Cells(i, 2).Value = (num)
Next i
'MsgBox num
End Sub
'--- Output will be
123466654
1234
1234
12354
Try the below piece of codes.
Assumption
Your data that you need to separate is in Column A
There is no blank cells in your data
Trim value will be displayed in the adjacent column i.e. Column B in subsequent cells
Code :
Dim LRow As Double
Dim i As Integer
Dim j As Integer
Dim LPosition As Integer
Dim Number As Double
LRow = Range("A1").End(xlDown).Row
For i = 1 To LRow
Number = 0
LPosition = InStr(1, Cells(i, 1), "J*")
For j = (LPosition + 2) To Len(Cells(i, 1))
If IsNumeric(Mid(Cells(i, 1), j, 1)) Then
num = Trim(num & Mid(Cells(i, 1), j, 1))
End If
Next j
Cells(i, 2).Value = Number
Next i
Related
I have to create a Macro which lets me Concatenate two columns at a time in a given range. For example: In range C1:Z200, I want to concatenate Column C&D, E&F, G&H and so on. How do I do it. This is my current code which only concatenate first two columns..rest remains the same.
Set Range = ActiveSheet.Range("C1:Z100")
For Each c In Range
c.Select
ActiveCell.FormulaR1C1 = ActiveCell & " " & ActiveCell.Offset(0, 1)
ActiveCell.Offset(0, 1).Activate
Selection.Clear
ActiveCell.Offset(0, 2).Activate
Next c
Try this:
Sub Concat()
Dim i As Long, j As Long
For i = 1 To 100 'number of rows
j = 1 'reset column to 1
Do While j < 25 'max number of columns (until Column Y-Z)
j = j + 2 'start from third column (Column C)
Cells(i, j) = Cells(i, j) & " " & Cells(i, j + 1) 'concat
Cells(i, j + 1).ClearContents 'clear
Loop
Next i 'next row
End Sub
Try this:
Sub ConcatAltCellsInAltCols()
Dim oW As Worksheet: Set oW = ThisWorkbook.Worksheets("Sheet11")
Dim iLC As Long: iLC = oW.Cells(1, oW.Columns.Count).End(xlToLeft).Column
Dim iLR As Long: iLR = oW.Cells(oW.Rows.Count, 3).End(xlUp).Row
Dim iC As Long
Dim iR As Long
For iR = 1 To iLR
For iC = 3 To iLC Step 2
oW.Cells(iR, iC).Value = oW.Cells(iR, iC) & oW.Cells(iR, iC + 1)
Next
Next
End Sub
Try this using a one based array for better Performance:
Code
Option Explicit
Sub Conc()
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("Concat") ' <== change "Concat" to your sheet name to avoid subscript error
Dim v ' variant
Dim lng As Long
Dim j As Integer ' corr.
' use one based array to get field data
v = ws.Range("C1:Z100") ' your OP range
For lng = 1 To UBound(v)
' concatenate columns C&D, E&F, G&H, ...
For j = 0 To 11
v(lng, j * 2 + 1) = v(lng, j * 2 + 1) & v(lng, j * 2 + 2)
Next j
Next lng
' write array values back (overwriting D, F, H,... with the same values)
ws.Range("C1:Z100") = v ' your OP range
End Sub
Have data spread across columns
Want to keep the first three columns fixed (columns a, b and c).
And convert columns from four onward into new rows (columns d --> last column where there is a value).
Example:
The colours from columns D -->onwards are NOT always green, blue, black red, etc.... they vary depending on the data loaded in from a power query table.
This is how I want the data to look:
Notice how columns A, B and C are fixed with the same info and only columns D onwards is recreating a new "row".
I've been trying to adapt a VBA script from a previous post on here, but I'm having some complications. I'm also trying to keep it on the sheet that the data is currently on, not create a new sheet. If it is easier to just create a new sheet.. then I can work with that.. Script:
Sub ColumnTorow()
Dim maxRows As Double
Dim maxCols As Integer
Dim data As Variant
maxRows = Cells(1, 1).End(xlDown).row
maxCols = Cells(1, 1).End(xlToRight).Column
data = Range(Cells(1, 1), Cells(maxRows, maxCols))
With ActiveSheet
Dim rRow As Long
rRow = 2
Dim row As Long
row = 2
Dim col As Integer
Do While True
col = 2
Do While True
If data(row, col) = "" Then Exit Do 'Skip Blanks
.Cells(rRow, 1).Value = data(row, 1)
.Cells(rRow, 2).Value = data(row, col)
rRow = rRow + 1
If col = maxCols Then Exit Do 'Exit clause
col = col + 1
Loop
If row = maxRows Then Exit Do 'exit cluase
row = row + 1
Loop
End With
End Sub
This is just an example code that I was provided with and I'm trying to modify... It might not even be the correct solution to this problem but figured I would post it anyways.
Here you go, since I did this yesterday, I got it together fairly quickly:
Sub ColumnToRow()
Dim maxRows As Double
Dim maxCols As Integer
Dim data As Variant
maxRows = Cells(1, 1).End(xlDown).row
maxCols = Cells(1, 1).End(xlToRight).Column
data = Range(Cells(1, 1), Cells(maxRows, maxCols))
Dim newSht As Worksheet
Set newSht = Sheets.Add
With newSht
.Cells(1, 1).Value = data(1, 1)
.Cells(1, 2).Value = data(1, 2)
.Cells(1, 3).Value = data(1, 3)
.Cells(1, 4).Value = data(1, 4)
Dim writeColumn As Double
writeColumn = 1
Dim writeRow As Double
writeRow = 2
Dim row As Double
row = 2
Do
writeColumn = 1
Dim col As Double
col = 4
Do While True
If data(row, col) <> "" Then
Dim firstColData As String
firstColData = data(row, 1)
.Cells(writeRow, writeColumn) = firstColData
writeColumn = 2
Dim secondColData As String
secondColData = data(row, 2)
.Cells(writeRow, writeColumn) = secondColData
writeColumn = 3
Dim thirdColData As String
thirdColData = data(row, 3)
.Cells(writeRow, writeColumn) = thirdColData
writeColumn = 4
.Cells(writeRow, writeColumn).Value = data(row, col)
writeColumn = 1
writeRow = writeRow + 1
End If
If col = maxCols Then
Exit Do 'Exit clause
End If
col = col + 1
Loop
If row = maxRows Then
Exit Do 'exit cluase
End If
row = row + 1
Loop While True
End With
End Sub
consider this code.
Sub TransData()
Dim vDB, vR()
Dim n As Long, i As Long, j As Integer, k As Integer
vDB = Range("a1").CurrentRegion
For i = 2 To UBound(vDB, 1)
For j = 4 To UBound(vDB, 2)
If vDB(i, j) <> "" Then
n = n + 1
ReDim Preserve vR(1 To 4, 1 To n)
For k = 1 To 3
vR(k, n) = vDB(i, k)
Next k
vR(4, n) = vDB(i, j)
End If
Next j
Next i
Sheets.Add
Range("a1").Resize(1, 4) = Array("Item", "Amount", "Price", "Color")
Range("a2").Resize(n, 4) = WorksheetFunction.Transpose(vR)
End Sub
I have a full dictionary. All the words (360 000) are in one column.
I'd like to have Column B with all words starting with "a", column C with all words starting with b...
I am trying to do a loop or something... but... It is just too long.
Any tips? Or did someone already do this vba macro?
Tks,
Stéphane.
If we start with:
Running this short macro:
Sub SeparateData()
Dim N As Long, i As Long, NewCol As Long
Dim M As Long
N = Cells(Rows.Count, 1).End(xlUp).Row
For i = 1 To N
NewCol = Asc(UCase(Left(Cells(i, 1).Value, 1))) - 63
If Cells(1, NewCol).Value = "" Then
M = 1
Else
M = Cells(Rows.Count, NewCol).End(xlUp).Row + 1
End If
Cells(M, NewCol).Value = Cells(i, 1).Value
Next i
End Sub
will produce:
NOTE:
You may want to add some error capture logic to the NewCol calculation line.
EDIT#1:
This version may be slightly faster:
Sub SeparateDataFaster()
Dim N As Long, i As Long, NewCol As Long
Dim M As Long, time1 As Date, time2 As Date
N = Cells(Rows.Count, 1).End(xlUp).Row
time1 = Now
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
For i = 1 To N
NewCol = Asc(UCase(Left(Cells(i, 1).Value, 1))) - 63
If Cells(1, NewCol).Value = "" Then
M = 1
Else
M = Cells(Rows.Count, NewCol).End(xlUp).Row + 1
End If
Cells(M, NewCol).Value = Cells(i, 1).Value
Next i
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
time2 = Now
MsgBox time1 & vbCrLf & time2
End Sub
You can try something like this.
For 360k records its take about 20sec.
To create tests data i use this sub:
Sub FillTestData()
Dim t As Long
Dim lng As Integer
Dim text As String
'Start = Timer
For t = 1 To 360000
text = vbNullString
lng = 5 * Rnd + 10
For i = 1 To lng
Randomize
text = text & Chr(Int((26 * Rnd) + 65))
Next i
Cells(t, 1) = text
Next t
'Debug.Print Timer - Start
End Sub
And for separate:
Sub sep()
'Start = Timer
Dim ArrWords() As Variant
Dim Row_ As Long
LastRow = Cells.Find("*", searchorder:=xlByRows, searchdirection:=xlPrevious).Row
ArrWords = Range("A1:A" & LastRow) 'all data from column A to array
For i = 65 To 90 ' from A to Z
Row_ = 1
For j = LBound(ArrWords, 1) To UBound(ArrWords, 1)
If Asc(UCase(ArrWords(j, 1))) = i Then
Cells(Row_, i - 63) = ArrWords(j, 1)
Row_ = Row_ + 1
End If
Next j
Next i
'other than a[A]-z[Z]
Row_ = 1
For j = LBound(ArrWords, 1) To UBound(ArrWords, 1)
If Asc(UCase(ArrWords(j, 1))) < 65 Or Asc(UCase(ArrWords(j, 1))) > 90 Then
Cells(Row_, 28) = ArrWords(j, 1)
Row_ = Row_ + 1
End If
Next j
'Debug.Print Timer - Start
End Sub
You could try:
For i = 1 To Cells(Rows.count, 1).End(xlUp).Row
Range(UCase(Left$(Cells(i, 1).Text, 1)) & Rows.count).Offset(0, 1).End(xlUp).Offset(IIf(Range(UCase(Left$(Cells(i, _
1).Text, 1)) & Rows.count).Offset(0, 1).End(xlUp).Row = 1, 0, 1), 0).Value = Cells(i, 1).Text
Next i
Which is just building the destination address using the first letter of the word by doing the following:
Loop through each cell in column A
Get the first letter of that cell and convert it to upper case
Find the last cell in the column starting with that letter
Move over 1 column to the right
Go up until we hit the last row of data
If the last row isn't row 1, move down another row (next blank cell)
Give this cell the same value as the cell in column A that we're assessing
You can enter the following formula:
For letter A in B Column:
=IF(UPPER(LEFT(A1,1))="A",A1,"")
For letter B in C Column:
=IF(UPPER(LEFT(A1,1))="B",A1,"")
Repeat the same for letter C, D and so on..
I need a macro to exports combinations from a range of many sets of values .
The sets of exporting combs will be smaler than the data range sets .
For examble lets say that i need all 2 set of values combinations of a 3 set of values in a data range .
DATA____ EXPORT
A B C____ AB AC BC
B B A____ BB BA BA
-
All the values of the data will be in different cels each one but the combs values must be in one cell each time.
Also the exports must be in horizontial as the example .
This is a code that ifound on web little close for me , but i cannot edit this to use it .
enter code here
Sub comb()
Dim vElements As Variant, vresult As Variant
Dim lRow As Long, i As Long
vElements = Application.Transpose(Range("A1", Range("A1").End(xlDown)))
Columns("C:Z").Clear
lRow = 1
For i = 1 To UBound(vElements)
ReDim vresult(1 To i)
Call CombinationsNP(vElements, i, vresult, lRow, 1, 1)
Next i
End Sub
Sub CombinationsNP(vElements As Variant, p As Long, vresult As Variant, lRow As Long,
iElement As Integer, iIndex As Integer)
Dim i As Long
For i = iElement To UBound(vElements)
vresult(iIndex) = vElements(i)
If iIndex = p Then
lRow = lRow + 1
Range("C" & lRow).Resize(, p) = vresult
Else
Call CombinationsNP(vElements, p, vresult, lRow, i + 1, iIndex + 1)
End If
Next i
End Sub
Thank you very much and sorry for my english .
I wonder if it was more convenient to use a new Sheet/ Range with cell reference
((= Sheet1! $A1 & Sheet1! B1)) this is three lines then copy
Sub Sub export_01()
Dim aStart, aExport
Dim aRow As Integer
aRow = ActiveSheet.Range("A65536").End(xlUp).Row
aStart = 1
aExport = 5
For i = 1 To aRow
Cells(i, aExport).Value = Cells(i, aStart) & Cells(i, aStart + 1)
Cells(i, aExport + 1).Value = Cells(i, aStart) & Cells(i, aStart + 2)
Cells(i, aExport + 2).Value = Cells(i, aStart + 1) & Cells(i, aStart + 2)
Next i
End Sub()
This seems to me simply use a second for loop
dim aStartend = 1
For i = 1 To aRow
For ii = 0 To 5 ' starts whist 0 to 5 = 6 time
Cells(i, aExport+ii).Value = Cells(i, aStart) & Cells(i,aStartend + ii)
--
--
next ii
next i
I'm using VBA to calculate pairwise slopes, store them in an array, then using Chip Pearson's technique of transposing the array on a workheet to sort them. My code fails when the number of slopes exceeds 65K, which would make sense in Excel 2003, due to number of rows. I thought it would work in Excel 2010, but I seem to have the same issue. Does anyone know if there's limitations to the Resize property or Transpose method?
Thanks
Sub pairwise()
Dim endrow As Long, i As Long, j As Long, s As Long
Dim num As Double, denom As Double, sij As Double
Dim r As Range
Dim slopes()
endrow = Range("A1").End(xlDown).Row
n = endrow - 1
nrd = endrow * n / 2
ReDim slopes(nrd)
Debug.Print LBound(slopes); UBound(slopes)
For i = 1 To n
For j = (i + 1) To endrow
num = Cells(i, 2).Value - Cells(j, 2).Value
denom = Cells(i, 1).Value - Cells(j, 1).Value
If denom <> 0 Then
sij = num / denom
slopes(s) = sij
s = s + 1
End If
Next j
Next i
Set r = Range("C1").Resize(UBound(slopes) - LBound(slopes) + 1, 1)
r = Application.Transpose(slopes)
' sort the range
r.Sort key1:=r, order1:=xlAscending, MatchCase:=False
End Sub
I found the same limitation on the INDEX function. http://dailydoseofexcel.com/archives/2013/10/11/worksheetfunction-index-limitations/
Here's how you can make the output array a two dimensional array and read in all the values at once rather than inside a loop.
Sub pairwise()
Dim lEndRow As Long
Dim vaValues As Variant
Dim aSlopes() As Variant
Dim lCnt As Long
Dim rOutput As Range
Dim i As Long, j As Long
'A 2d array here can easily be written to a sheet
lEndRow = Sheet3.Range("a1").End(xlDown).Row
ReDim aSlopes(1 To lEndRow * (lEndRow - 1), 1 To 1)
'Create a two-d array of all the values
vaValues = Sheet3.Range("A1").Resize(lEndRow, 2).Value
'Loop through the array rather than the cells
For i = LBound(vaValues, 1) To UBound(vaValues, 1) - 1
For j = 1 + 1 To UBound(vaValues, 1)
If vaValues(i, 1) <> vaValues(j, 1) Then
lCnt = lCnt + 1
aSlopes(lCnt, 1) = (vaValues(i, 2) - vaValues(j, 2)) / (vaValues(i, 1) - vaValues(j, 1))
End If
Next j
Next i
'Output the array to a range, and sort
Set rOutput = Sheet3.Range("C1").Resize(UBound(aSlopes, 1), UBound(aSlopes, 2))
rOutput.Value = aSlopes
rOutput.Sort rOutput.Cells(1), xlAscending, , , , , , , , False
End Sub
It a limitation of the Transpose method.
My suggestion would be to declare your array as 2D from the start
Redim Slopes(1 To nrd, 1 To 1)
Also, your should use the Variant Array approach instead of looping over cells in your For loop