I have a macro which fills values in Column G (starting at cell G2) based on user prompts for the start value, then repeats to the end of the column by adding 10 to the value each time.
Sub Macro1()
Dim TagName As String
Dim TagNum As Long, k As Long
' Prompts user for tag names/numbers
TagName = InputBox("What is the product tag name? Ex. APPLE")
TagNum = InputBox("What is the starting tag #? Ex. 10")
' Set values in column G, up to last row in column J
k = 0
With ActiveSheet
LastRow = .Cells(.Rows.Count, "J").End(xlUp).Row
End With
With ActiveSheet.Range("G2")
For i = 1 To LastRow Step 1
.Item(i + 0) = TagName & "_" & TagNum2 + k
k = k + 10
Next
End With
End Sub
This works perfectly if Column C has unique values in each line, like so:
But if the value in Column C repeats, I want the same in Column G, like this:
I think there are couple of errors. Is this what you are trying?
Sub Sample()
Dim TagName As String, sTag As String
Dim TagNum As Long, k As Long
' Prompts user for tag names/numbers
TagName = InputBox("What is the product tag name? Ex. APPLE")
TagNum = InputBox("What is the starting tag #? Ex. 10")
With ActiveSheet
LastRow = .Cells(.Rows.Count, "J").End(xlUp).Row
k = TagNum
.Range("G2").Value = TagName & "_" & k
For i = 3 To LastRow
'~~> Increment k only if the values do not match
If .Range("C" & i).Value <> .Range("C" & i - 1).Value _
Then k = k + 10
.Range("G" & i).Value = TagName & "_" & k
Next
End With
End Sub
I selected "Apple" and "10" in the Input Boxes
Related
I am looking for a code, that can find each cell that starts with the number "2347" in column L. I want to get the cell adresses for these cells and display it in a MessageBox for example "Msgbox: Cells L3500:L3722 has a value starts starts with "2347" "
Sub Findrow()
Dim MyVal As Integer
Dim LastRow As Long
MyVal = LEFT(c.Value,4) = "2347" _
LastRow = Cells(Rows.Count, "L").End(xlUp).Row
For Each c In Range("L2:L" & LastRow)
If c.Value = Myval Then
This is my code so far. Hope someone can help me!
Using arrays is quite fast
Option Explicit
Public Sub FindIDInColL()
Const VID = "2347" 'Value to find
Dim ws As Worksheet, arrCol As Variant, found As Variant
Set ws = ActiveSheet 'Or Set ws = ThisWorkbook.Worksheets("Sheet3")
arrCol = ws.Range(ws.Cells(2, "L"), ws.Cells(ws.Rows.Count, "L").End(xlUp))
ReDim found(1 To UBound(arrCol))
Dim r As Long, f As Long, msg As String
f = 1
For r = 1 To UBound(arrCol) 'Iterate vals in col L, excluding header row
If Not IsError(arrCol(r, 1)) Then 'Ignore errors
If Len(arrCol(r, 1)) > 3 Then 'Check only strings longer than 3 letters
If Left$(arrCol(r, 1), 4) = VID Then 'Check first 4 letters
found(f) = r + 1 'Capture rows containing value (header offset)
f = f + 1
End If
End If
End If
Next
If f > 1 Then 'If any cells found
ReDim Preserve found(1 To f - 1) 'Drop unused array items
msg = "Cells in col L starting with """ & VID & """" & vbNewLine & vbNewLine
MsgBox msg & " - L" & Join(found, ", L"), , "Total Found: " & f - 1
Else
MsgBox "No cells starting with """ & VID & """ found in col L", , "No matches"
End If
End Sub
Even faster when using the string versions of these functions
Left$() Mid$() Right$() Chr$() ChrW$() UCase$() LCase$()
LTrim$() RTrim$() Trim$() Space$() String$() Format$()
Hex$() Oct$() Str$() Error$
They are more efficient (if Null is not a concern), as pointed out by QHarr
You may try this:
Option Explicit
Sub Findrow()
Dim MyVal As String ' "2347" is a String
Dim LastRow As Long
Dim c As Range, myCells As Range
MyVal = "2347"
LastRow = cells(Rows.Count, "L").End(xlUp).row
Set myCells = Range("M2") 'initialize cells with a dummy cell certainly out of relevant one
For Each c In Range("L2:L" & LastRow)
If Left(c.Value2, 4) = MyVal Then Set myCells = Union(myCells, c) ' if current cell matches criteria then add it to cells
Next
If myCells.Count > 1 Then MsgBox "Cells " & Intersect(myCells, Range("L:L")).Address(False, False) & " have values starting with ‘2347’" ' if there are other cells than the dummy one then get rid of this latter and show their addresses
End Sub
So at Assign sheet I indicate the sheets to take data for each group (each for column and the first row is the explanation of the group). I dynamically can add res at the file or delete
After I use predefined codes to assign which type of discounts / day are applied. At the example I only put two codes (C and S) and one week. For example the raw sheet data for designations Red and Black.
Data product worksheet
Then at Diary I want to show the result of concatenate the B1 value (name of product) each time code fromm price are indicated into the rows. Also I use two loop because at raw product data I have one column for price but at the Diary I have two
Summary page
This is what I finally want to get and doing like that because my boss don't know anything for code and he wan't edite it so I try to do ll dynamic at the sheets :) [I only put two images because i don't have reputations point enough to put more]
With the formula I only get FALSE as answer :(, and I need to get what you can see at summary page
Sub Diary()
Dim I As Integer, x As Integer, y As Integer, z As Integer, n As Integer
Dim p As Integer, d As Integer, f As Integer
Dim a As String, b As String
Dim element As Variant
' Initialize variables I and y at 3 and 4 to begin to show the data at the column I desire. Also x and z were intended to pass the one column mode data sheet to the two column mode at the summary page.
I = 3
x = 1
y = 4
z = 0
With Worksheets("Asign")
.Activate
.Range("B2").Select
End With
' Set the size of Data with sheet names it get form the page assign. It can dynamically changed as size as names of sheets
With ActiveSheet
r = .Cells(.Rows.Count, "B").End(xlUp).Row
End With
Dim Data() As String
ReDim Data(r)
For p = 1 To r - 1
Data(p) = ActiveSheet.Cells(p + 1, "B").Value
Next p
With Worksheets("Diary")
.Activate
.Range("C7").Select
End With
' At Diary concatenate the same cell for all the sheets I have his name stored at Data() and then pass to the next cell with data at raw data sheets (in the images (Red, Black ,... pages). In this case search for code S
Do
Cells(7, I).Select
ActiveCell.Value = ActiveCell.FormulaR1C1 = "=CONCATENATE(" & a & ")"
For Each element In Data
b = ActiveCell.FormulaR1C1 = "IF(Data& !R[-2]C[" & x & "]=""S"",CONCATENATE(Data&!R1C2,"", ""),"""")"
a = b & ";" & b
Next element
x = x - 1
I = I + 2
Loop While I < 4
' The same for the second column of summary sheet called Diary. In this case search for code C
Do
Cells(7, y).Select
ActiveCell.Value = ActiveCell.FormulaR1C1 = _
"=CONCATENATE(" & a & ")"
For Each element In Data
b = ActiveCell.FormulaR1C1 = "IF(Data& !R[-2]C[" & z & "]=""S"",CONCATENATE(Data&!R1C2,"", ""),"""")"
a = b & ";" & b
Next element
z = z - 1
y = y + 2
Loop While I < 4
' Drag and Drop the formula to all the sheet's cells you need
Range("C8:E8").Select
Selection.AutoFill Destination:=Range("C8:E10"), Type:=xlFillDefault
'
End Sub
try this. .... could be simplified by looping through "colors" .... black, red, etc
Sub Diary()
Dim red As Variant
red = Sheets("red").Range("d6:g12") ' put range data into an array for processing
Dim black As Variant
black = Sheets("black").Range("d6:g12")
Dim i As Integer
Dim j As Integer
Dim strC As String
Dim strS As String
For i = 1 To 7
For j = 1 To 4
strC = ""
strS = ""
If LCase(black(i, j)) = "c" Then strC = "Black"
If LCase(black(i, j)) = "s" Then strS = "Black"
If LCase(red(i, j)) = "c" Then
If Len(strC) > 1 Then strC = strC & ";"
strC = strC & "Red"
End If
If LCase(red(i, j)) = "s" Then
If Len(strS) > 1 Then strS = strS & ";"
strS = strS & "Red"
End If
Sheets("diary").Range("c7").Cells(i, j * 2 - 1) = strS
Sheets("diary").Range("c7").Cells(i, j * 2) = strC
Next j
Next i
End Sub
Iam new to Excel VBA , I am started writing a code , which was executed fine, but I need a suggestion how to write a function where i dont need to write code for all "ID".
For example :
I have main works sheet having ID(1000x, 10000, 2000X,20000).
I want to search only ID with number not with alphabet, and compare it with another worksheet , having the same ID , if then get the corrosponding ID 3rd column data and conacdenate all them into main worksheet .
I have main worksheet ("Tabelle1")having all the ID(10000,20000) in Coloumn A ,I want the infomration of ID 10000 in column B of ID 10000. some times i have 10000 for four times . Want to paste infomration to another worksheet ("Test_2"), I want to collect all the 10000 and corrosponding data .
Sub Update()
If MsgBox("Are you sure that you wish to Update New Measurement ?", vbYesNo, "Confirm") = vbYes Then
Dim erow As Long, erow1 As Long, i As Long
erow1 = Sheets("Tabelle1").Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To erow1
If Sheets("Tabelle1").Cells(i, 2) <> "10000" Then
Sheets("Tabelle1").Range(Sheets("Tabelle1").Cells(i, 1), Sheets("Tabelle1").Cells(i, 2)).Copy
Sheets("Test_2").Activate
erow = Sheets("Test_2").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
ActiveSheet.Paste Destination:=Sheets("Test_2").Range(Cells(erow, 1), Cells(erow, 2))
Sheets("Test_2").Activate
End If
Next i
Application.CutCopyMode = False
For i = 1 To erow
Totalstrings = Totalstrings & Cells(i, 2) & "" + vbCrLf
Next i
Totalstrings = Left(Totalstrings, Len(Totalstrings) - 1)
Range("C5") = Totalstrings
Range("C5").Select
Selection.Copy
Sheets("BSM_STF_iO").Select
Range("C5").Select
ActiveSheet.Paste
MsgBox "New measurements have been Updated !"
End If
End Sub
Example
In BSM:STM:IO
A B
ID
1000X
10000
10001
...
in Tabelle1
B C
ID
1000 abc
1000 xyz
10001 lmn
2000 def
"
I want to compare only digit from"the "BSM:STM:Io" with "tabelle1". Example take the the first value 10000 from "BSM_STM_io" compare with tabele take the the value of corrosponding Coloumn "C" in "tablle1" and put it into single cell in 1000 of BSM_STM:Io
A , B , C are coloumn in the worksheet
enter image description here
Lets assume worksheet "BSM_STF_iO" contains the ID information in A column beginning with A2 and worksheet Tabelle1 contains the required concaetenation information in B Column beginning from B2 (ex: Column B: IDs, Column C: information to concaetenate). Below code will concaetenate the contents and write in BSM_STF_iO sheet.
Sub test1()
Worksheets("BSM_STF_iO").Select
LastRow = Range("A" & Rows.Count).End(xlUp).Row
For i = 2 To LastRow
a = onlyDigits(Range("A" & i).Value)
With Worksheets("Tabelle1")
destlastrow = .Range("B" & Rows.Count).End(xlUp).Row
For j = 2 To destlastrow
If a = Trim(.Range("B" & j).Value) Then
If out <> "" Then
out = out & ", " & .Range("C" & j).Value
Else
out = .Range("C" & j).Value
End If
End If
Next j
Cells(i, 2) = out
out = ""
End With
Next i
End Sub
and below function taken from How to find numbers from a string?
Function onlyDigits(s As String) As String
Dim retval As String
Dim i As Integer
retval = ""
For i = 1 To Len(s)
If Mid(s, i, 1) >= "0" And Mid(s, i, 1) <= "9" Then
retval = retval + Mid(s, i, 1)
End If
Next
onlyDigits = retval
End Function
I have the following VBA code:
Sub test():
Dim NameValue As String, w1 As Worksheet, w2 As Worksheet
Dim i As Long, j As Long, k As Long, c As Long
Set w1 = Sheets("Sheet2"): Set w2 = Sheets("Sheet3")
GetNameValue: For i = 1 To w1.Range("A" & Rows.Count).End(xlUp).row
If w1.Range("A" & i) = "NAME:" Then
If InStr(1, NameValue, w1.Range("B" & i)) Then GoTo GetNext
j = i + 1: Do Until w1.Range("A" & j) = "DATE OF BIRTH:": j = j + 1: Loop
NameValue = Trim(NameValue & " " & w1.Range("B" & i) & "|" & w1.Range("B" & j))
c = c + 1: End If
GetNext: Next i: NameValue = NameValue & " "
For k = 1 To c
i = InStr(1, NameValue, "|"): j = InStr(i, NameValue, " ")
w2.Range("A" & k) = Left(NameValue, i - 1): w2.Range("B" & k) = Mid(NameValue, i + 1, j - i)
NameValue = Mid(NameValue, j + 1, Len(NameValue) - j)
Next k
End Sub
To break down what this code does:
1) Set the first sheet that should be searched and the second sheet (output sheet) that the results should be appended to.
2) Search the first column for a certain string "NAME:" and once found take the value in the second column, place it in the output sheet go look for "DATE OF BIRTH:". Once "DATE OF BIRTH:" is found put it beside the value for "NAME:" in the output sheet.
3) Repeat until there are no more entries.
I'm sure this is a very simple modification, but what I'd like to do is check whether a certain string exists, if it does grab the entry directly BELOW it, and then continue searching for the next string and associated entry just like the code does already.
Can anyone point me to what I would need to change in order to do this (and preferably why)?
In addition, how might I be able to extend this code to run over multiple sheets while depositing the results in a single sheet? Do I need to set up a range running over the worksheets w_1....w_(n-1) (with output sheet w_n possibly in a different workbook)?
Removed Line continuations in code:
Sub test()
Dim NameValue As String, w1 As Worksheet, w2 As Worksheet
Dim i As Long, j As Long, k As Long, c As Long
Set w1 = Sheets("Sheet2")
Set w2 = Sheets("Sheet3")
GetNameValue:
For i = 1 To w1.Range("A" & Rows.Count).End(xlUp).Row
If w1.Range("A" & i) = "NAME:" Then
If InStr(1, NameValue, w1.Range("B" & i)) Then GoTo GetNext
j = i + 1
Do Until w1.Range("A" & j) = "DATE OF BIRTH:"
j = j + 1
Loop
NameValue = Trim(NameValue & " " & w1.Range("B" & i) & "|" & w1.Range("B" & j))
c = c + 1
End If
GetNext:
Next i
NameValue = NameValue & " "
For k = 1 To c
i = InStr(1, NameValue, "|")
j = InStr(i, NameValue, " ")
w2.Range("A" & k) = Left(NameValue, i - 1)
w2.Range("B" & k) = Mid(NameValue, i + 1, j - i)
NameValue = Mid(NameValue, j + 1, Len(NameValue) - j)
Next k
End Sub
UPDATE: Just to make sure we're all on the same page about what the output would look like. Suppose we are searching for the entry below A and the entry beside C:
INPUT
A 1
B
y 3
z 4
t
d
s 7
C 8
A 1
Z
y 3
z 4
t
d
s 7
C 12
OUTPUT
B 8
Z 12
.
.
.
Assuming I understand your desire correctly, you can use the .Offset method with your current range to get to the cell below it. You would need to add a dim, so here's my stab at what you're trying to accomplish:
Sub test()
Dim NameValue As String, w1 As Worksheet, w2 As Worksheet
'new local variable
Dim newValue as string
Dim i As Long, j As Long, k As Long, c As Long
Set w1 = Sheets("Sheet2")
Set w2 = Sheets("Sheet3")
GetNameValue:
For i = 1 To w1.Range("A" & Rows.Count).End(xlUp).Row
'assuming your string is in column A
If w1.Range("A" & i) = "FIND ME" Then
newValue = w1.Range("A" & i).Offset(1,0).Value
End If
If w1.Range("A" & i) = "NAME:" Then
If InStr(1, NameValue, w1.Range("B" & i)) Then GoTo GetNext
j = i + 1
Do Until w1.Range("A" & j) = "DATE OF BIRTH:"
j = j + 1
Loop
NameValue = Trim(NameValue & " " & w1.Range("B" & i) & "|" & w1.Range("B" & j))
c = c + 1
End If
GetNext:
Next i
NameValue = NameValue & " "
For k = 1 To c
i = InStr(1, NameValue, "|")
j = InStr(i, NameValue, " ")
w2.Range("A" & k) = Left(NameValue, i - 1)
w2.Range("B" & k) = Mid(NameValue, i + 1, j - i)
NameValue = Mid(NameValue, j + 1, Len(NameValue) - j)
Next k
End Sub
Then you could do anything you desired with the newValue string, including putting it in w2 like so: w2.Range("D1").value = newValue
UPDATED ANSWER
I am now 89% sure I know what you are trying to accomplish :) thanks for your clarifying example.
To search a range for your search string, you need to set up a range you are looking in:
dim searchRange as range
dim w1,w2 as worksheet
Set w1 = Sheets("Sheet1")
Set w2 = Sheets("Sheet2")
set searchRange = w1.Range("A" & Rows.Count).End(xlUp).Row
Then you search the searchRange for both of your search strings (which I'm saying are "A" for the first and "C" for the second). As long as both strings are found in the searchRange, it will create a new Dictionary entry for the two values, having the value below "A" as the key and the value beside "C" as the item.
dim rng as range
dim valueBelowFirstSearch as string
dim resultsDictionary as object
dim i as integer
dim c, d as range
dim cAddress, dAddress as string
set resultsDictionary = CreateObject("scripting.dictionary")
with searchRange
set c = .Find("A", lookin:=xlValues)
set d = .Find("C", lookin:=xlValues)
if not c Is Nothing and not d Is Nothing then
cAddress = c.address
dAddress = d.address
resultsDictionary.add Key:=c.offset(1,0).value, Item:=d.value
Do
set c = .FindNext(c)
set d = .FindNext(d)
Loop While not c is nothing and not d is nothing and c.address <> cAddress and d.address <> dAddress
end if
end with
Now that we have all of the results in the resultsDictionary, we can now output the values into another place, which I'm choosing to be w2.
dim outRange as range
dim item as variant
set outRange = w2.Range("A1")
for each item in resultsDictionary
outRange.Value = item.key
set outRange = outRange.Offset(0,1)
outRange.Value = item.item
set outRange = outRange.Offset(1,-1)
next item
Can anyone point me to what I would need to change in order to do this
(and preferably why)?
Basically you need to change the parts of which NameValue is composed.
Originally you took the value beside the first match as w1.Range("B" & i) and now you want the value below the first match, which is w1.Range("A" & i + 1).
Originally it was:
Trim(NameValue & " " & w1.Range("B" & i) & "|" & w1.Range("B" & j))
Now you need something like this:
Trim(NameValue & " " & w1.Range("A" & i + 1) & "|" & w1.Range("B" & j))
In addition, how might I be able to extend this code to run over
multiple sheets while depositing the results in a single sheet?
(with output sheet w_n possibly in a different workbook)?
To achieve that you can e.g. create an array of Sheets and let the code run for each Sheet of this array. Note that the array might contain 1-N Sheets.
' Set array of sheets for just one sheet
Dim searchedSheets As Sheets
Set searchedSheets = Workbooks("SomeBook.xlsx").Sheets(Array("Sheet1"))
' Set array of sheets for more sheets, e.g. "Sheet1" and "Sheet2" and "Sheet3"
Dim searchedSheets As Sheets
Set searchedSheets = Workbooks("SomeBook.xlsx").Sheets(Array("Sheet1", "Sheet2", "Sheet3"))
' Finally set the second sheet where the results should be appended
' to sheet in the same workbook as the searched sheets
Dim outputSheet As Worksheet
Set outputSheet = Workbooks("SomeBook.xlsx").Worksheets("ResultSheet")
' Or set the second sheet where the results should be appended to sheet
' in a different workbook then the searched sheets belong to
Dim outputSheet As Worksheet
Set outputSheet = Workbooks("SomeOtherBook.xlsx").Worksheets("ResultSheet")
The complete code might look like this (tested with data you provided).
Option Explicit
Public Sub main()
' String to search below of it
Dim string1 As String
string1 = "A"
' String to search beside of it
Dim string2 As String
string2 = "C"
' Set the sheets that should be searched
Dim searchedSheets As Sheets
Set searchedSheets = Workbooks("SomeBook.xlsx").Sheets(Array("Sheet1", "Sheet2"))
' Set the second sheet (outputSheet sheet) that the results should be
' appended to external sheet in different book
Dim outputSheet As Worksheet
Set outputSheet = Workbooks("SomeOtherBook.xlsx").Worksheets("ResultSheet")
SearchFor string1, string2, searchedSheets, outputSheet
End Sub
Public Sub SearchFor( _
string1 As String, _
string2 As String, _
searchedSheets As Sheets, _
output As Worksheet)
Dim searched As Worksheet
Dim NameValue As String
Dim below As String
Dim beside As String
Dim i As Long
Dim j As Long
Dim k As Long
Dim c As Long
Dim rowsCount As Long
For Each searched In searchedSheets
rowsCount = searched.Range("A" & Rows.Count).End(xlUp).Row
For i = 1 To rowsCount
' Search the first column for a 'string1'
If searched.Range("A" & i) = string1 Then
' once 'string1' was found grab the entry directly below it
below = searched.Range("A" & i + 1)
If InStr(1, NameValue, below) Then
' skip this 'below' result because it was found before
GoTo GetNext
End If
' Search the first column for a 'string2' starting at the
' position where 'below' was found
For j = i + 1 To rowsCount
If searched.Range("A" & j) = string2 Then
' once 'string2' was found grab the entry directly
' beside it
beside = searched.Range("B" & j)
Exit For
End If
Next j
' Append 'below' and 'beside' to the result and count the
' number of metches
NameValue = Trim(NameValue & " " & below & "|" & beside)
c = c + 1
End If
GetNext:
Next i
Next searched
' Write the output
NameValue = NameValue & " "
For k = 1 To c
i = InStr(1, NameValue, "|")
j = InStr(i, NameValue, " ")
output.Range("A" & k) = Left(NameValue, i - 1)
output.Range("B" & k) = Mid(NameValue, i + 1, j - i)
NameValue = Mid(NameValue, j + 1, Len(NameValue) - j)
Next k
End Sub
Note: I replaced the Do-Until loop with For-Next loop because the Do-Until might cause a Stack-Overflow :-) error if the string "DATE OF BIRTH:" does not exist in the first column. However I have tryied to keep your originall code structure so you still understand it. HTH.
Assuming that you want to find one value (Name:), then continue searching till to find the second one (Date Of Birth:)... Finally, you want to move these pair of data into another worksheet.
To achieve that, i'd suggest to use Dictionary object to get only distinct values. I strongly do not recommend to use string concatenation as you provided in your code!
Option Explicit
Sub Test()
Dim src As Worksheet, dst As Worksheet
Set dst = ThisWorkbook.Worksheets("Sheet2")
For Each src In ThisWorkbook.Worksheets
If src.Name = dst.Name Then GoTo SkipNext
NamesToList src, dst
SkipNext:
Next
End Sub
'needs reference to MS Scripting Runtime library
Sub NamesToList(ByVal srcWsh As Worksheet, ByVal dstWsh As Worksheet, _
Optional ByVal SearchFor As String = "NAME:", Optional ByVal ThenNextFor As String = "DATE OF BIRTH:")
Dim dic As Dictionary, i As Long, j As Long, k As Long
Dim sKey As String, sVal As String
On Error GoTo Err_NamesToList
Set dic = New Dictionary
i = 2
j = GetFirstEmpty(srcWsh)
Do While i < j
If srcWsh.Range("A" & i) = SearchFor Then
sKey = srcWsh.Range("B" & i)
If Not dic.Exists(sKey) Then
Do While srcWsh.Range("A" & i) <> ThenNextFor
i = i + 1
Loop
sVal = srcWsh.Range("B" & i)
dic.Add sKey, sVal
k = GetFirstEmpty(dstWsh)
With dstWsh
.Range("A" & k) = sKey
.Range("B" & k) = sVal
End With
'sKey = ""
'sVal = ""
End If
End If
SkipNext:
i = i + 1
Loop
Exit_NamesToList:
On Error Resume Next
Set dic = Nothing
Exit Sub
Err_NamesToList:
Resume Exit_NamesToList
End Sub
Function GetFirstEmpty(ByVal wsh As Worksheet, Optional ByVal sCol As String = "A") As Long
GetFirstEmpty = wsh.Range(sCol & wsh.Rows.Count).End(xlUp).Row + 1
End Function
Sample output:
Name DateOfBirth:
A 1999-01-01
B 1999-01-02
C 1999-01-03
D 1999-01-04
E 1999-01-05
I have a columns filled with string cells separated by spaces such as:
"abc def ghi jkl"
"abcde fghi jkl"
"abcdef ghijkl"
"abcdefghijkl"
My objectives are:
When there is four words I take each of the first letters of each word
When there is three words I take the first two letters of the first word and then each of the first letters of the following words
When there is two words I take the first two letters of each word
When there is only one word I take the first four letters
For each case I copy the resulting four letters found into another cell on the same row.
Being new to vba I didn't go very far. I started with Case 1 but it is incomplete and not returning anything:
Sub MyMacro()
Dim r As Range
Dim a, b, c, d, s As String
Dim v As Variant
Dim w As Worksheet
Set w = Worksheets("Sheet1")
w.Activate
Set r = w.Range("B1").End(xlDown).Rows
For Each v In r.Cells
If UBound(Split(v, " ")) = 3 Then
a = Left(Split(v, " ")(0), 1)
b = Left(Split(v, " ")(1), 1)
c = Left(Split(v, " ")(2), 1)
d = Left(Split(v, " ")(3), 1)
End If
Next
End Sub
Why aren't a, b, c and d not returning anything?
While I am looping through the cells of the range, how do I say that I want to copy the concatenated values of a, b, c and d into an adjacent cell?
Edited to replace "#" with " ".
Sub MyMacro()
Dim r As Range
Dim a, b, c, d, s As String
Dim v As Variant
Dim w As Worksheet
Dim arr, res
Set w = Worksheets("Sheet1")
w.Activate
Set r = w.Range(w.Range("B1"), w.Range("B1").End(xlDown))
For Each v In r.Cells
arr = Split(v.Value, " ")
select case ubound(arr)
case 0: res=left(arr(0),4)
case 1:'etc
case 2:'etc
case 3:'res = left(arr(0),1) & left(arr(1),1)'...etc
case else: res = "???"
End Select
v.offset(0,1).value=res
Next v
End Sub
Let's say your worksheet looks like this
Then try this
Option Explicit
Sub Sample()
Dim ws As Worksheet
Dim lRow As Long, i As Long, n As Long
Dim MyAr, sval
Set ws = ThisWorkbook.Sheets("Sheet1")
With ws
lRow = .Range("A" & .Rows.Count).End(xlUp).Row
For i = 1 To lRow
sval = .Range("A" & i).Value
If InStr(1, sval, " ") Then
MyAr = Split(sval, " ")
n = UBound(MyAr) + 1
Select Case n
Case 2:
.Range("B" & i).Value = Left(MyAr(0), 2) & Left(MyAr(1), 2)
Case 3
.Range("B" & i).Value = Left(MyAr(0), 2) & Left(MyAr(1), 1) & Left(MyAr(2), 1)
Case 4
.Range("B" & i).Value = Left(MyAr(0), 1) & Left(MyAr(1), 1) & _
Left(MyAr(2), 1) & Left(MyAr(3), 1)
End Select
Else
.Range("B" & i).Value = Left(sval, 4)
End If
Next i
End With
End Sub
Output