I want to break selection (B3, B4..etc) into new row.. Please help me.
for a example= If I select B3 cell, I wanna add more 3 Rows and 2nd to 4th line should be move down. Always not same line break in each cell.
Splitting the cell into an array of strings is simple with excel-vba using the Split function.
If cell A1 contains a string with Chr(10)'s (LF/Linefeed characters) then you could split it into an array with VBA like this:
Dim myArr() as String
myArr = Split(Range("A1"), Chr(10))
...then you could dump it into a range of cells horizontally (with the help of UBound) like this:
Dim startColumn As Integer
startColumn = 2
Range(Cells(1, startColumn), Cells(1, startColumn + UBound(myArr))) = myArr()
...or you could dump it into a range of cells vertically like this:
Dim startRow As Integer, x As Integer
startRow = 2
For x = 0 To UBound(myArr)
Range("A" & x + startRow) = myArr(x)
Next x
You haven't shared the code you've tried so far, but I trust you'll should be able to handle the "inserting rows" part with Range.Insert, or a quick Google Search (if you don't already know how).
use split function and variant array.
Sub test()
Dim vSplit
Dim vDB, vR()
Dim i As Long, n As Long, j As Integer
vDB = Range("a1").CurrentRegion
For i = 1 To UBound(vDB, 1)
vSplit = Split(vDB(i, 2), Chr(10))
For j = 0 To UBound(vSplit)
n = n + 1
ReDim Preserve vR(1 To 3, 1 To n)
If j = 0 Then
vR(1, n) = vDB(i, 1)
vR(3, n) = vDB(i, 3)
End If
vR(2, n) = vSplit(j)
Next j
Next i
Sheets.Add
Range("a1").Resize(n, 3) = WorksheetFunction.Transpose(vR)
End Sub
Related
I looked for the answer of my problem in all topics discussed on this platform such as Compare two Sheet and find differences, Macro to compare two worksheets & highlights differences and so on ... but I did not found what I was looking for.
My question is ; is there a possibility to compare two excel worksheets with a different layout as below? I'm willing to compare an historical worksheets versus a new worksheets and display in a third worksheet what was on the new worksheet that does not exist in the historical e.g :
I hope you will understand my question and be able to help me on this topic. I already have a code which compare two worksheet and show the difference but it's not enough for my problem.
Option Explicit
Sub CompareIt()
Dim ar As Variant
Dim arr As Variant
Dim Var As Variant
Dim v()
Dim i As Long
Dim n As Long
Dim j As Long
Dim str As String
ar = Sheet1.Cells(10, 1).CurrentRegion.Value
With CreateObject("Scripting.Dictionary")
.CompareMode = 1
ReDim v(1 To UBound(ar, 2))
For i = 2 To UBound(ar, 1)
For n = 1 To UBound(ar, 2)
str = str & Chr(2) & ar(i, n)
v(n) = ar(i, n)
Next
.Item(str) = v: str = ""
Next
ar = Sheet2.Cells(10, 1).CurrentRegion.Resize(, UBound(v)).Value
For i = 2 To UBound(ar, 1)
For n = 1 To UBound(ar, 2)
str = str & Chr(2) & ar(i, n)
v(n) = ar(i, n)
Next
If .exists(str) Then
.Item(str) = Empty
Else
.Item(str) = v
End If
str = ""
Next
For Each arr In .keys
If IsEmpty(.Item(arr)) Then .Remove arr
Next
Var = .items: j = .Count
End With
With Sheet3.Range("a1").Resize(, UBound(ar, 2))
.CurrentRegion.ClearContents
.Value = ar
If j > 0 Then
.Offset(1).Resize(j).Value = Application.Transpose(Application.Transpose(Var))
End If
End With
End Sub
Thanks in advance
I was wondering if someone can help me with the following,
In VBA in Excel, I have the following table :
Column 1|Column2|Column3|Column4|Column5|Column6
---------|---------|---------|---------|---------|---------
1.2.3.4|Apple%Car|Canada%USA|Tomatoes|Hotel|Montreal%Paris%New-York
1.3.4.6|Cat%Uniform%Dog|France|Ananas|Motel|Amsterdam%San-Diego
And I would like to convert this in Excel using VBA into the following table :
Column 1|Column 2|Column 3|Column 4|Column 5|Column 6
:---------:|:---------:|:---------:|:---------:|:---------:|:---------:
1.2.3.4|Apple|Canada|Tomatoes|Hotel|Montreal
1.2.3.4|Apple|Canada|Tomatoes|Hotel|Paris
1.2.3.4|Apple|Canada|Tomatoes|Hotel|New-York
1.2.3.4|Apple|USA|Tomatoes|Hotel|Montreal
1.2.3.4|Apple|USA|Tomatoes|Hotel|Paris
1.2.3.4|Apple|USA|Tomatoes|Hotel|New-York
1.2.3.4|Car|Canada|Tomatoes|Hotel|Montreal
1.2.3.4|Car|Canada|Tomatoes|Hotel|Paris
1.2.3.4|Car|Canada|Tomatoes|Hotel|New-York
1.2.3.4|Car|USA|Tomatoes|Hotel|Montreal
1.2.3.4|Car|USA|Tomatoes|Hotel|Paris
1.2.3.4|Car|USA|Tomatoes|Hotel|New-York
1.3.4.6|Cat|France|Ananas|Motel|Amsterdam
1.3.4.6|Cat|France|Ananas|Motel|San-Diego
1.3.4.6|Uniform|France|Ananas|Motel|Amsterdam
1.3.4.6|Uniform|France|Ananas|Motel|San-Diego
1.3.4.6|Dog|France|Ananas|Motel|Amsterdam
1.3.4.6|Dog|France|Ananas|Motel|San-Diego
Does anyone have an idea how to do this ?
Thank you !
To get my brain going I bit. This does more or less what you want (However there is room for improvement as it currently can produce duplicate rows which it then removes at the end. I've missed something but as you haven't tried anything I haven't put any more effort in figuring out where this is happening exactly).
You'll also have to change the Ranges for where your inputs and outputs come from in the ConvertToTable sub. This uses a recursive function (i.e. one that calls itself) to populate your output
Option Explicit
Public Sub ConvertToTable()
Dim data As Variant, tmp() As Variant
Dim arr() As Variant
Dim i As Long
Dim c As Range
With Sheet2
data = Range(.Cells(1, 1), .Cells(2, 6)).Value2
End With
For i = LBound(data, 1) To UBound(data, 1)
tmp = Application.Index(data, i, 0)
arr = PopulateResults(tmp, "%", arr)
Next i
With Sheet4
With .Range(.Cells(1, 1), .Cells(UBound(arr, 2), UBound(arr, 1)))
.Value2 = Application.Transpose(arr)
.RemoveDuplicates Columns:=Array(1, 2, 3, 4, 5, 6), Header:=xlNo
End With
End With
End Sub
Public Function PopulateResults(tmp As Variant, delimiter As String, Results() As Variant) As Variant()
Dim i As Long, j As Long
Dim DelCount As Long, MaxDel As Long
Dim tmp2 As Variant
On Error Resume Next
i = UBound(Results, 2) + 1
If i = 0 Then i = 1
On Error GoTo 0
ReDim Preserve Results(1 To UBound(tmp), 1 To i)
For j = 1 To UBound(tmp)
Results(j, i) = tmp(j)
If InStr(1, tmp(j), delimiter, vbTextCompare) Then
DelCount = 0
Results(j, i) = Split(tmp(j), delimiter)(DelCount)
Do
DelCount = DelCount + 1
tmp2 = tmp
tmp2(j) = Split(tmp(j), delimiter)(DelCount)
Results = PopulateResults(tmp2, delimiter, Results)
Loop Until DelCount = Len(tmp(j)) - Len(Replace(tmp(j), delimiter, vbNullString))
End If
Next j
PopulateResults = Results
End Function
Thank you very much, It is much appreciated. Sorry for the delay, I didn't get any e-mail notification for the response.
I played with the source code and I have the following, it works for all the column that contain short value.. :
'Transform the data
Dim data As Variant, tmp() As Variant
Dim arr() As String
Dim i As Long
Dim c As Range
With Aggregation_Source
data = Range(Cells(1, 1), Cells(2, 8)).Value2
End With
For i = LBound(data, 1) To UBound(data, 1)
tmp = Application.Index(data, i, 0)
arr = PopulateResults(tmp, "%", arr)
Next i
With Aggregation_Source
With Range(Cells(1, 1), Cells(UBound(arr, 2), UBound(arr, 1)))
.Value2 = Application.Transpose(arr)
.RemoveDuplicates Columns:=Array(1, 2, 3, 4, 5, 6, 7), Header:=xlNo
End With
End With
End Sub
Public Function PopulateResults(tmp As Variant, delimiter As String, Results() As String) As String()
Dim i As Long, j As Long
Dim DelCount As Long, MaxDel As Long
Dim tmp2 As Variant
On Error Resume Next
i = UBound(Results, 2) + 1
If i = 0 Then i = 1
On Error GoTo 0
ReDim Preserve Results(1 To UBound(tmp), 1 To i)
For j = 1 To UBound(tmp)
Results(j, i) = tmp(j)
If InStr(1, tmp(j), delimiter, vbTextCompare) Then
DelCount = 0
Results(j, i) = Split(tmp(j), delimiter)(DelCount)
Do
DelCount = DelCount + 1
tmp2 = tmp
tmp2(j) = Split(tmp(j), delimiter)(DelCount)
Results = PopulateResults(tmp2, delimiter, Results)
Loop Until DelCount = Len(tmp(j)) - Len(Replace(tmp(j), delimiter, vbNullString))
End If
Next j
PopulateResults = Results
End Function
Now, I think that the code crash because I have one column that contains two long text separated by % more than a 1000 characters, I will try to change the type for arr() to see if it works but I think I am missing something in the code .
I'm not a developer but I read a bit here and there to be able to understand some of it. This might be a simple problem that I'm facing but I can't seem to figure it out. So thank you for helping me on this!
I wrote with the help of Google a short script that is supposed to turn a CSV export into a readable format. It is supposed to do a few more things but I'm already facing performance issues just with the objective of making a few entries readable.
Here's what I have so far:
Sub MagicButton_Click()
'Find the last non-empty cell in column A
Dim LastRow As Long
LastRow = Range("A" & Rows.Count).End(xlUp).Row
'Set Variables to work with the cell content
Dim CellContent As String
Dim CellContentArr As Variant
'Set looping variables
Dim i, j As Integer
Dim FirstRow As Integer
Dim FirstCol As Integer
Dim ActiveCol As Integer
Dim itm As Variant
FirstRow = 1
FirstCol = 2
Dim x, y As String
'Loop (1) through all rows
For i = FirstRow To LastRow
'Save cell content to string
CellContent = ActiveSheet.Cells(i, 1).Text
'Split string into array
CellContentArr = Split(CellContent, "{")
'Reset column
ActiveCol = FirstCol
'Loop (2) through the array
For Each itm In CellContentArr
'Remove quotations and other symbols
itm = Application.WorksheetFunction.Clean(itm)
itm = Replace(itm, """", "")
'This is the part that creates performance issues
'For j = 1 To Len(itm)
' x = Mid(itm, j, 1)
' If x Like "[A-Z,a-z,0-9 :.-]" Then
' y = y & x
' End If
'Next j
'itm = y
'y = ""
'Write each item in array to an individual cells within the same row
ActiveSheet.Cells(i, ActiveCol) = itm
ActiveCol = ActiveCol + 1
Next itm
Next i
End Sub
This entire script works fine when I test on ~10 rows. When using it on the entire set of 220 rows, it becomes unresponsive and eventually crashes.
In the script I have commented what causes this performance issue. I'm guessing it is because there are three loops. The third loop iterates through every char in the string to check if it is an allowed char or not and then keeps or deletes it.
What can I do to improve performance, or at least, make it so that Excel doesn't turn unresponsive?
Sidenote: It is supposed to work both on Mac & Windows. I don't know if RegEx would have a better performance to filter out the unwanted char, but I also don't know if it is possible to use that for both Mac & Windows.
The answers that have been given would be good adjustments to your code. However, there might be a better approach to this.
Firstly, reading a range into an array and manipulating the resultant array is markedly faster than reading cell by cell.
Secondly, if you are iterating each character in your array and checking for specific items with a curly bracket signalling a new column, then couldn't you just do it all in one iteration. It seems a little redundant to split and clean first.
All in all, your code could be as simple as this:
Dim lastCell As Range
Dim v As Variant
Dim r As Long
Dim c As Long
Dim i As Integer
Dim output() As String
Dim b() As Byte
'Read the values into an array
With ThisWorkbook.Worksheets("Sheet1")
Set lastCell = .Cells(.Rows.Count, "A").End(xlUp)
v = .Range(.Cells(1, "A"), lastCell).Value2
End With
ReDim output(1 To UBound(v, 1), 1 To 1)
'Loop through the array rows and characters
For r = 1 To UBound(v, 1)
c = 1
'Convert item to byte array - just personal preference, you could iterate a string
b = StrConv(v(r, 1), vbFromUnicode)
For i = 0 To UBound(b)
Select Case b(i)
Case 45, 46, 58, 65 To 90, 97 To 122, 48 To 57 '-, :, ., A-Z, a-z, 0-9
output(r, c) = output(r, c) & Chr(b(i))
Case 123 '{
'add a column and expand output array if necessary
If Len(output(r, c)) > 0 Then
c = c + 1
If c > UBound(output, 2) Then
ReDim Preserve output(1 To UBound(v, 1), 1 To c)
End If
End If
Case Else
'skip it
End Select
Next
Next
'Write item to worksheet
ThisWorkbook.Worksheets("Sheet1").Cells(1, "B") _
.Resize(UBound(output, 1), UBound(output, 2)).Value = output
Three things - you need to disable screenupdating and you need to declare variables in a better way. Do not do it like "Dim a,b,c,d,e as Integer", because only the last one is integer, the others are variant. Last but not least, do not use Integer in VBA, but this is not your problem here.
This should work faster:
Sub MagicButton_Click()
'Find the last non-empty cell in column A
Dim LastRow As Long
LastRow = Range("A" & Rows.Count).End(xlUp).Row
'Set Variables to work with the cell content
Dim CellContent As String
Dim CellContentArr As Variant
'Set looping variables
Dim i As Long
dim j as Long
Dim FirstRow As Long
Dim FirstCol As Long
Dim ActiveCol As Long
Dim itm As Variant
FirstRow = 1
FirstCol = 2
Dim x as string
dim y As String
call onstart
'Loop (1) through all rows
For i = FirstRow To LastRow
'Save cell content to string
CellContent = ActiveSheet.Cells(i, 1).Text
'Split string into array
CellContentArr = Split(CellContent, "{")
'Reset column
ActiveCol = FirstCol
'Loop (2) through the array
For Each itm In CellContentArr
'Remove quotations and other symbols
itm = Application.WorksheetFunction.Clean(itm)
itm = Replace(itm, """", "")
'This is the part that creates performance issues
'For j = 1 To Len(itm)
' x = Mid(itm, j, 1)
' If x Like "[A-Z,a-z,0-9 :.-]" Then
' y = y & x
' End If
'Next j
'itm = y
'y = ""
'Write each item in array to an individual cells within the same row
ActiveSheet.Cells(i, ActiveCol) = itm
ActiveCol = ActiveCol + 1
Next itm
Next i
call onend
End Sub
Public Sub OnStart()
Application.AskToUpdateLinks = False
Application.ScreenUpdating = False
Application.Calculation = xlAutomatic
Application.EnableEvents = False
Application.DisplayAlerts = False
End Sub
Public Sub OnEnd()
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.StatusBar = False
Application.AskToUpdateLinks = True
End Sub
Task List
Copy source range into an array
Clean array
Copy array back to source range
Split data into multiple columns using TextToColumns
Sub MagicButton_Click2()
Dim arData
Dim LastRow As Long, i As Integer
Dim dataRange As Range
LastRow = Range("A" & rowS.Count).End(xlUp).Row
Set dataRange = Range(Cells(1, 1), Cells(LastRow, 1))
arData = dataRange.value
For i = 1 To UBound(arData)
arData(i, 1) = AlphaNumericOnly(CStr(arData(i, 1)))
Next
dataRange.value = arData
dataRange.TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar _
:="{", TrailingMinusNumbers:=True
End Sub
' http://stackoverflow.com/questions/15723672/how-to-remove-all-non-alphanumeric-characters-from-a-string-except-period-and-sp
Function AlphaNumericOnly(strSource As String) As String
Dim i As Integer
Dim strResult As String
For i = 1 To Len(strSource)
Select Case Asc(Mid(strSource, i, 1))
Case 48 To 57, 65 To 90, 97 To 123: 'include 32 if you want to include space I added 123 to include the {
strResult = strResult & Mid(strSource, i, 1)
End Select
Next
AlphaNumericOnly = strResult
End Function
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
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