I have a cell with a full address. I want to copy street name and street number to the next cell. E.g "STRANDVEJEN 100 MIDDELFART DENMARK"
In this example I want "STRANDVEJEN 100" to be copied.
Currently everything is being copied to the next cell.
But I need advice how to continue
Sub move()
Range("C3:C2000").Copy Range("D3:D2000")
Do until......
End Sub
I need help with the do until part.
Try:
Option Explicit
Sub CopyYes()
Dim arr As Variant, strSplit As Variant
Dim i As Long
With ThisWorkbook.Worksheets("Sheet1")
arr = .Range("C3:C2000")
For i = LBound(arr) To UBound(arr)
strSplit = Split(arr(i, 1), " ")
.Range("E" & i + 2).Value = strSplit(0)
.Range("F" & i + 2).Value = strSplit(1)
Next i
End With
End Sub
Results:
Here is a function that will perform your 'cut' on a string. It's not pretty and it could no doubt be better written with a simple reg-ex command but..
Function untilnumeric(txt As String) As String
Dim i As Long
Dim started As Boolean
For i = 1 To Len(txt)
If Asc(Mid(txt, i, 1)) > 47 And Asc(Mid(txt, i, 1)) < 58 Then
started = True
Else
If started = True And Asc(Mid(txt, i, 1)) = 32 Then
untilnumeric = Left(txt, i - 1)
Exit For
End If
End If
Next
End Function
You could use it like this to perform it on column C - copying the result to D:
Range("D3:D2000").Value = Range("C3:C2000").Value
For Each c In Range("D3:D2000").Cells
c.Value = untilnumeric(c.Value)
Next
Note: Amended slightly to pick up any letters within the number part. eg.100A
Related
I'm trying to cut out a part of a cell value.
This is how it should look:
So far I got this:
For Each item In arr
pos = InStr(item, "No")
If pos > 0 Then
ActiveSheet.Range("B" & row).Value = item
row = row + 1
Else
ActiveSheet.Range("B" & row).Value = " N/A "
row = row + 1
End If
This returns me the rows but i still need to cut out the Values
-----Update-----
This is what i have now:
Sub cut()
Call Variables
Dim arr() As Variant
Dim element As Variant
Dim element2 As Variant
Dim rows As Integer
Dim rows2 As Integer
arr = Array("test352532_No223", _
"testfrrf43tw_No345figrie_ge", _
"test123_No32_fer", _
"test_Nhuis34", _
"teftgef_No23564.345")
With ThisWorkbook.Worksheets("Numbers").Activate
rows = 1
rows2 = 1
For Each element In arr
Range("A" & rows).Value = element
With regEx
.Pattern = "(No[1-9][\.\d]+[a-z]?)"
Set mc = regEx.Execute(element)
For Each element2 In mc
ActiveSheet.Range("B" & rows2).Value = element2
rows2 = rows2 + 1
Next element2
End With
rows = rows + 1
Next element
End With
End Sub
And this is what it results:
So the problem is, that the Value in B4 should be in B5...
Formula:
Formula in B1:
=IFERROR("No"&-LOOKUP(1,-MID("_"&SUBSTITUTE(A1,".","|"),FIND("_No","_"&A1)+3,ROW($1:$99))),"")
Notes:
Add leading _ to allow for match at start of string;
FIND() is case-sensitive;
SUBSTITUTE() out the dot to prevent longer match with FIND();
The above will not work well when 1st digit after No is a zero.
VBA:
If VBA is a must, try an UDF, for example:
Function GetNo(s As String) As String
With CreateObject("vbscript.regexp")
.Pattern = "^(?:.*?_)?(No\d+)?.*$"
GetNo = .Replace(s, "$1")
End With
End Function
On your worksheets in B1, invoke through typing =GetNo(A1).
Here I used regular expressions to 'cut' the substring you are after. See an online demo. The pattern means:
^ - Start-line anchor;
(?:.*?_)? - Optional non-capture group to match 0+ (Lazy) characters upto underscore. This would also allow No at start of string;
(No\d+)? - Optional capture group to match No (case-sensitive) followed by 1+ digits;
.* - 0+ Characters;
$ - End-line anchor.
EDIT: You can also call the function in your VBA-project:
Sub Test()
arr = Range("A1:A5").Value
For x = LBound(arr) To UBound(arr)
arr(x, 1) = GetNo(CStr(arr(x, 1)))
Next
Range("B1").Resize(UBound(arr)).Value = arr
End Sub
Please, test the next function:
Function extractNoStr(x As String) As String
Dim frst As Long, last As Long, i As Long
frst = InStr(1, x, "No", vbBinaryCompare)
For i = frst + 2 To Len(x)
If Not IsNumeric(Mid(x, i, 1)) Then last = i: Exit For
Next i
If i > Len(x) And last = 0 Then last = Len(x) + 1
extractNoStr = Mid(x, frst, last - frst)
End Function
It can be tested as:
Sub testExtractNoStr()
Dim x As String
x = "test2345_No345figrie_ge"
Debug.Print extractNoStr(x)
Debug.Print activeCell.value 'select a cell containing such a string...
End Sub
To process all range of column A:A, returning in B:B, please use the next code:
Sub extractAll()
Dim sh As Worksheet, lastR As Long, arr, arrFin, i As Long
Set sh = ActiveSheet
lastR = sh.Range("A" & sh.rows.count).End(xlUp).row
arr = sh.Range("A1:A" & lastR).Value2 'place the range in an array for faster processing
ReDim arrFin(1 To UBound(arr), 1 To 1) 'ReDim the final array to receive all occurrences
For i = 1 To UBound(arr)
arrFin(i, 1) = extractNoStr(CStr(arr(i, 1)))
Next i
'drop the processed array content, at once:
sh.Range("B1").Resize(UBound(arrFin), 1).Value2 = arrFin
End Sub
I'm working on a VBA word script that reads in some names and relevant info from an excel sheet, performs some computations to organize them correctly, and then pastes them into the word doc. This went well until I decided to make a function that would move a cell with the value "Anonymous" to the top of a range. For some reason, this isn't happening, and it appears to be because the .Cells method isn't always referring to the cell it was called on.
As the script itself is fairly long, I won't post the entire thing here. However, the relevant parts are a For loop in the main sub which deals with cells with the value "Anonymous"
For curCol = 7 To 15
lastRow = appXL.Cells(appXL.Rows.Count, curCol).End(xlUp).Row
For curRow = 1 To lastRow
Dim curCell As excel.Range
Set curCell = appXL.Cells(curRow, curCol)
Dim anonCount As Integer
anonCount = 0
If curCell.Value = "Anonymous" Or curCell.Value = "Anonymous*" Then
If anonCount < 1 Then
anonCount = anonCount + 1
MoveAnon (curRow), (curCol), (lastRow)
Else
anonCount = anonCount + 1
curCell.Value = curCell.Value + " (" + CStr(anonCount) + ")"
MoveAnon (curRow), (curCol), (lastRow)
End If
End If
Next curRow
Next curCol
You'll notice that within this loop is a call to a subroutine "MoveAnon" which is
Sub MoveAnon(currentRow As Integer, currentCol As Integer, thelastRow As Integer)
Dim text As String
Debug.Print ("Using Row: " + CStr(currentRow) + ", Column: " + CStr(currentCol) + ", Last Row: " + CStr(thelastRow))
text = excel.Application.ActiveSheet.Cells(currentRow, currentCol)
Debug.Print ("Hit On: " & excel.Application.ActiveSheet.Cells(currentRow, currentCol))
If currentRow > 1 Then
excel.Application.ActiveSheet.Range(excel.Application.ActiveSheet.Cells(1, currentCol).Address, excel.Application.ActiveSheet.Cells(currentRow - 1, currentCol).Address).Cut excel.Application.ActiveSheet.Range(excel.Application.ActiveSheet.Cells(2, currentCol).Address)
excel.Application.ActiveSheet.Cells(1, currentCol).Value = text
End If
End Sub
Through testing and with Deubg.Print, I've noticed that the line Debug.Print ("Hit On: " & excel.Application.ActiveSheet.Cells(currentRow, currentCol)) refers to all manner of different cells then the one on which it was called. For example, whenever I use Cells(6, 15), I get a value from a cell that is actually on row 42, column 15. The difference between the cell its called on and the cell it returns is not always the same (I've seen -7, +36, and 0), but it is always in the correct column.
Does anyone have any idea as to what my cause this behavior to arise? Thanks for any help.
It's much faster to read the whole range into an array, then populate another array of the same size with the "Anonymous*" at the top, and replace the range values using the second array.
Eg.
Sub Tester()
Dim curCol As Long, ws As Worksheet
Set ws = ActiveSheet
For curCol = 7 To 15
MoveAnon ws.Range(ws.Cells(1, curCol), _
ws.Cells(ws.Rows.Count, curCol).End(xlUp))
Next curCol
End Sub
'Given a (single-column) range, move all values like "Anonymous*"
' to the top of the range
Sub MoveAnon(rng As Range)
Const TXT As String = "Anonymous*"
Dim v, i As Long, num As Long
Dim arrIn, arrOut, nA As Long, nX As Long
num = Application.CountIf(rng, TXT) 'how many to float up
If num = 0 Then Exit Sub 'nothing to do here?
arrIn = rng.Value 'read to array
ReDim arrOut(1 To UBound(arrIn, 1), 1 To UBound(arrIn, 2)) 'size output array
For i = 1 To UBound(arrIn, 1) 'loop the input array
v = arrIn(i, 1)
If v Like TXT Then
nA = nA + 1
arrOut(nA, 1) = v '"Anonymous*" goes at the top
Else
nX = nX + 1
arrOut(num + nX, 1) = v 'everything else goes below
End If
Next i
rng.Value = arrOut 'replace using the shuffled array
End Sub
I was wondering what would be the most efficient way to create a UDF in VBA that concatenate an range from the worksheet with an additional character, let's say a comma.
I tried some variations, but I always get stuck with one problem, how to resize the array from the range selected in the worksheet automatically.
The bellow code works, but I believe there must be a more efficient way to do it.
Can you guys help me out, please?
Thanks.
Function conc(data As Range) As String
Dim hola() As Variant
t = data.Rows.Count
ReDim hola(1 To t)
a = 1
For Each i In data.Value
hola(a) = i & ","
a = a + 1
Next i
conc = Join(hola)
Erase hola
End Function
For concatenating many strings in one column and many rows (which is what your original is designed to do):
Function vconc(data As Range) As String
vconc = Join(Application.Transpose(data), Chr(44))
End Function
To concatenate many columns of strings in a single row:
Function hconc(data As Range) As String
hconc = Join(Application.Transpose(Application.Transpose(data)), Chr(44))
End Function
Don't know about more efficient. You can concatenate a specific column with
Public Function conc(ByVal data As Range) As String
conc = Join(Application.WorksheetFunction.Transpose(Application.WorksheetFunction.Index(data.Value, 0, 1)), ",")
End Function
The 1 indicates the column number of the array to concatenate.
Subject to limitations of index and transpose.
More than one column:
Public Function conc(ByVal data As Range) As String
Dim i As Long
For i = 1 To data.Columns.Count
conc = conc & Join(Application.WorksheetFunction.Transpose(Application.WorksheetFunction.Index(data.Value, 0, i)), ",")
Next i
End Function
This function I wrote some time back is pretty efficient and comprehensive...it handles 1d or 2d arrays, and you can skip blanks and add delimiters if you like. For an explanation and worked examples, see http://dailydoseofexcel.com/archives/2014/11/14/string-concatenation-is-like-the-weather/ and for a discussion on the efficiency benefits of the VBA JOIN function vs straight concatenation see http://excellerando.blogspot.com/2012/08/join-and-split-functions-for-2.html
Option Explicit
Public Function JoinText( _
InputRange As Range, _
Optional SkipBlanks As Boolean = False, _
Optional Delimiter As String = ",", _
Optional FieldDelimiter As String = ";", _
Optional EndDelimiter As String = vbNull, _
Optional Transpose As Boolean) As String
'Based on code from Nigel Heffernan at Excellerando.Blogspot.com
'http://excellerando.blogspot.co.nz/2012/08/join-and-split-functions-for-2.html
' Join up a 1 or 2-dimensional array into a string.
' ####################
' # Revision history #
' ####################
' Date (YYYYMMDD) Revised by: Changes:
' 20141114 Jeff Weir Turned into worksheet function, added FinalDelimiter and Transpose options
' 20141115 Jeff Weir Changed FinalDelimiter to EndDelimiter that accepts string, with default of ""
' 20150211 Jeff Weir Changed names of arguments and changed default orientation to Column=>Row
Dim InputArray As Variant
Dim i As Long
Dim j As Long
Dim k As Long
Dim lngNext As Long
Dim i_lBound As Long
Dim i_uBound As Long
Dim j_lBound As Long
Dim j_uBound As Long
Dim arrTemp1() As String
Dim arrTemp2() As String
If InputRange.Rows.Count = 1 Then
If InputRange.Columns.Count = 1 Then
GoTo errhandler 'InputRange is a single cell
Else
' Selection is a Row Vector
InputArray = Application.Transpose(InputRange)
End If
Else
If InputRange.Columns.Count = 1 Then
' Selection is a Column Vector
InputArray = InputRange
Transpose = True
Else:
'Selection is 2D range. Transpose it, because our
' default input is data in rows
If Not Transpose Then
InputArray = Application.Transpose(InputRange)
Else: InputArray = InputRange
End If
End If
End If
i_lBound = LBound(InputArray, 1)
i_uBound = UBound(InputArray, 1)
j_lBound = LBound(InputArray, 2)
j_uBound = UBound(InputArray, 2)
ReDim arrTemp1(j_lBound To j_uBound)
ReDim arrTemp2(i_lBound To i_uBound)
lngNext = 1
For i = j_lBound To j_uBound
On Error Resume Next
If SkipBlanks Then
If Transpose Then
ReDim arrTemp2(i_lBound To WorksheetFunction.CountA(InputRange.Columns(i)))
Else
ReDim arrTemp2(i_lBound To WorksheetFunction.CountA(InputRange.Rows(i)))
End If
End If
If Err.Number = 0 Then
k = 1
For j = i_lBound To i_uBound
If SkipBlanks Then
If InputArray(j, i) <> "" Then
arrTemp2(k) = InputArray(j, i)
k = k + 1
End If
Else
arrTemp2(j) = InputArray(j, i)
End If
Next j
arrTemp1(lngNext) = Join(arrTemp2, Delimiter)
lngNext = lngNext + 1
Else:
Err.Clear
End If
Next i
If SkipBlanks Then ReDim Preserve arrTemp1(1 To lngNext - 1)
If lngNext > 2 Then
JoinText = Join(arrTemp1, FieldDelimiter)
Else: JoinText = arrTemp1(1)
End If
If JoinText <> "" Then JoinText = JoinText & EndDelimiter
errhandler:
End Function
I am new to VBA and need help in figuring out a faster way to execute my code. Here is the code I am using:
Sub loop()
For i = 1 To 100000
check_cell = Sheets("Sheet1").Range("I" & i)
For j = 1 To 14430
text_to_check = Sheets("Sheet2").Range("D" & j)
text_to_fill = Sheets("Sheet2").Range("E" & j)
If InStr(check_cell, text_to_check) Then
Sheets("Sheet1").Range("J" & i).Value = text_to_fill
End If
Next j
Next i
End Sub
I know that I am using a very brutal way by running the system through a loop 1,443,000,000 times. Any help on shortening this would be appreciated. Thanks.
EDIT: Based on suggestion, I tried with new code using variants but nothing seems to be happening. Would you be able to tell me what am I doing wrong here? Thanks
Sub loop_2()
Dim varray_1 As Variant
Dim varray_2 As Variant
Dim i As Long
Dim j As Long
varray_1 = Sheets("L1").Range("I2:I39997").Value
varray_2 = Sheets("Sheet2").Range("G1:G14394").Value
For i = UBound(varray_1, 1) To LBound(varray_1, 1) Step -1
For j = UBound(varray_2, 1) To LBound(varray_2, 1) Step -1
If varray_1(i, 1) = varray_2(j, 1) Then
Sheets("L1").Range("L" & i).Value = Sheets("Sheet2").Range("H" & j).Value
End If
Next j
Next i
End Sub
I haven't tested this code, but it should at least give an idea of how to put the values into arrays, process everything "in-memory", and then write the results out.
Sub loop()
Dim i As Long
Dim j As Long
Dim check_cell() As Variant
Dim result() As Variant
Dim text_to_check() As Variant
Dim text_to_fill() As Variant
check_cell = Sheets("Sheet1").Range("I1:I100000").Value
result = Sheets("Sheet1").Range("J1:J100000").Value
text_to_check = Sheets("Sheet2").Range("D1:D14430").Value
text_to_fill = Sheets("Sheet2").Range("E1:E14430").Value
For i = 1 To 100000
For j = 1 To 14430
If InStr(check_cell(i, 1), text_to_check(j, 1)) Then
result(i, 1) = text_to_fill(j, 1)
If i = 1 Then
Debug.Print "check_cell=" & check_cell(i, 1)
Debug.Print "j=" & j
Debug.Print "text_to_check=" & text_to_check(j, 1)
Debug.Print "text_to_fill=" & text_to_fill(j, 1)
End If
' exit as soon as first match is made
Exit For
End If
Next j
Next i
Sheets("Sheet1").Range("J1:J100000").Value = result
End Sub
The most cost here is using InStr(), but you should also:
Declare your variables, Variant are slower
Wrap your loops with
With Sheets("Sheet1")
...
End With
Change cell addressing to .Cell(10, i) instead of .Range("D" & j)
My tests show it runs 50% faster, note that I had all cells empty, so the InStr() cost is relatively low in that case.
I have data that I need to split into individual points. My macro charts the data, as a scatter plot, with: Column A as the title of the chart, Column B as the X axis, and Columns C and D as the Y axis. What I need is for when the Product ID has more than 1 number listed to split the numbers out into their own rows and keep the columns B, C, and D the same for each row created form the original. So for row 167, I would want 3 rows (001,002,003) each with packaging, 200, and 100, in B, C, and D respectively. I am not sure where to begin. I tried to build a macro but, I immediately got tripped up when I tried to record a "Find" Formula to run on the data. Any help would be greatly appreciated.
Column A: 001, 002, 003 // Column B:packaging // Column C:200 // Column D:100
Sorry I couldn't post a screenshot of my data, the forum won't let me. If you have any questions please let me know, I will be sure to check in frequently.
Thanks in advance.
I worte this VERY quickly and without much care for efficiency, but this should do the trick:
Sub SplitUpVals()
Dim i As Long
Dim ValsToCopy As Range
Dim MaxRows As Long
Dim ValToSplit() As String
Dim CurrentVal As Variant
MaxRows = Range("A1").End(xlDown).Row
For i = 1 To 10000000
ValToSplit = Split(Cells(i, 1).Value, ",")
Set ValsToCopy = Range("B" & i & ":D" & i)
For Each CurrentVal In ValToSplit
CurrentVal = Trim(CurrentVal)
Cells(i, 1).Value = CurrentVal
Range("B" & i & ":D" & i).Value = ValsToCopy.Value
Cells(i + 1, 1).EntireRow.Insert
i = i + 1
MaxRows = MaxRows + 1
Next
Cells(i, 1).EntireRow.Delete
If i > MaxRows Then Exit For
Next i
End Sub
As a note, make sure there's no data in cells beneath your data as it might get deleted.
You will need to parse the data in column A. I would do this by splitting the string in to an array, and then iterate over the array items to add/insert additional rows where necessary.
Without seeing your worksheet, I would probably start with something like this, which will split your cell value from column A in to an array, and then you can iterate over the items in the array to manipulate the worksheet as needed.
Sub TestSplit()
Dim myString as String
Dim myArray() as String
Dim cell as Range
Dim i as Long
For each cell in Range("A2",Range("A2").End(xlDown))
myString = cell.Value
myArray = Split(myString, ",") '<-- converts the comma-delimited string in to an array
For i = lBound(myArray) to uBound(myArray)
If i >= 1 Then
'Add code to manipulate your worksheet, here
End If
Next
Next
End Sub
This is a better solution (now that I had more time :) ) - Hope this does the trick!
Sub SplitUpVals()
Dim AllVals As Variant
Dim ArrayIndex As Integer
Dim RowLooper As Integer
AllVals = Range("A1").CurrentRegion
Range("A1").CurrentRegion.Clear
RowLooper = 1
For ArrayIndex = 1 To UBound(AllVals, 1)
ValToSplit = Split(AllVals(ArrayIndex, 1), ",")
For Each CurrentVal In ValToSplit
CurrentVal = Trim(CurrentVal)
Cells(RowLooper, 1).Value = CurrentVal
Cells(RowLooper, 2).Value = AllVals(ArrayIndex, 2)
Cells(RowLooper, 3).Value = AllVals(ArrayIndex, 3)
Cells(RowLooper, 4).Value = AllVals(ArrayIndex, 4)
RowLooper = RowLooper + 1
Next
Next ArrayIndex
End Sub
Sub DivideData()
'This splits any codes combined into the same line, into their own separate lines with their own separate data
Dim a, b, txt As String, e, s, x As Long, n As Long, i As Long, ii As Long
With Range("a1").CurrentRegion
a = .Value
txt = Join$(Application.Transpose(.Columns(1).Value))
x = Len(txt) - Len(Replace(txt, ",", "")) + .Rows.Count
ReDim b(1 To x * 2, 1 To UBound(a, 2))
For i = 1 To UBound(a, 1)
For Each e In Split(a(i, 1), ",")
If e <> "" Then
For Each s In Split(e, "-")
n = n + 1
For ii = 1 To UBound(a, 2)
b(n, ii) = a(i, ii)
Next
b(n, 1) = s
Next
End If
Next
Next
With .Resize(n)
.Columns(1).NumberFormat = "#"
.Value = b
End With
End With
End Sub