I am writing a little Excel-Macro with VBA. Now I would like to concat two Strings and save them into a String-Array.
What I got:
Dim rowNumberString As String
Dim colIndexString As String
Dim headerArray(1 To colIndexArrayRange) As String
colIndexNumber = 14
colCount = 5
rowNumberString = "12"
addAnotherColumnToArray = True
' Fill the column array with all the month's entries
While addAnotherColumnToArray
colCount = colCount + 1
colIndexNumber = colIndexNumber + 1
If colIndexArray(colCount) = "" Then
colIndexString = Split(Cells(1, colIndexNumber).Address(True, False), "$")(0)
colIndexArray(colCount) = colIndexString & rowNumberString
End If
Debug.Print colCount & "=" & colIndexArray(colCount)
If (colIndexNumber > 61) Then
addAnotherColumnToArray = False
End If
Wend
The output:
6=O
7=P
8=Q
9=R
10=S
11=T
12=U
' ....
So it seems that this line:
` colIndexArray(colCount) = colIndexString & rowNumberString`
is not concatenating the String the way it should. What did I do wrong? I thought the &-Operator would always work for Strings in VBA.
As I stated in my comment, you could be going about this in a completely different way.
Not sure what you are trying to accomplish, but a For...Next statement using Objects, rather than Strings should help you accomplish your task.
Option Explicit
Sub TEST()
Dim ws As Worksheet, Rng12 As Range, Cell As Range
Set ws = ThisWorkbook.Worksheets(1)
Set Rng12 = ws.Range("L12:Z12") 'Adjust your range
For Each Cell In Rng12
Debug.Print Cell.Address
Next Cell
End Sub
Related
I need to run a macro between two worksheets where say column C in "Sheet 1" has a "Y", I need column AP in "Sheet 2" to return something along the lines of "covered" or "Y". Just something to indicate that a Y was there in Sheet 1. I am mainly running issues in actually connecting the two worksheets. This code below works fine if I am running it on columns within the same work sheet.
Code:
Private Sub Set_Border_Pattern(Requirements_Selector_Str As String)
Dim strTemp As String
Dim strRange As String
Dim strCellVal As String
If Len(Requirements_Selector_Str) > 2 Then
strTemp = Mid(Requirements_Selector_Str, 4, 1)
Else
strTemp = Requirements_Selector_Str
End If
With Worksheets("test")
For i = 2 To REQUIREMENT_ROW_COUNT
strRange = strTemp & i
strCellVal = .Range(strRange).Value
If strCellVal = "Y" Then
Worksheets("NFR_List").Range(AP & i).Value = "Y"
End If
Next i
End With
The code below does what you describe in a very simple way. I believe that if you understand it you will be able to modify it for your situation. If not, please feel free to ask questions.
Sub test()
Dim sh1 As Worksheet, sh2 As Worksheet
Dim r1 As Range, r2 As Range, i As Long
Set sh1 = Worksheets("test")
Set sh2 = Worksheets("NFR_List")
Set r1 = sh1.Range("C1")
Set r2 = sh2.Range("AP1")
i = 0
While r1.Offset(i, 0) <> ""
If r1.Offset(i, 0) = "Y" Then r2.Offset(i, 0) = "Y"
i = i + 1
Wend
End Sub
I've assumed that Column C has no blank cells until the data is finished, but if this is not true, the code can be easily modified according to your needs.
Another approach would be to just use a formula for this (instead of VBA), such as =IF(test!C1="Y", "Y","") in AP1 (if the "NFR_List" sheet) and then drag the formula down. Or you could also put the formula in using VBA using code like, r2.offset(i,0).formula = ... . There are many ways.
What I'm looking to do is comb through a column and pull all the unique identifiers out of that column and then paste the results in a table in a different worksheet. I found the code below and it is very close to what I need. However, I have two major problems with it that I cannot figure out. First the area that this macro searches is constant ie "A1:B50". I need this to be one column and be dynamic since more data and new unique identifiers will be added to this worksheet. Second I cannot figure out how to paste my results to a specific range on a different worksheet. For example if I wanted to take the results and paste them in "sheet2" starting in at "B5" and going to however long the list of unique identifiers is.
Sub ExtractUniqueEntries()
Const ProductSheetName = "Sheet1" ' change as appropriate
Const ProductRange = "B2:B"
Const ResultsCol = "E"
Dim productWS As Worksheet
Dim uniqueList() As String
Dim productsList As Range
Dim anyProduct
Dim LC As Integer
ReDim uniqueList(1 To 1)
Set productWS = Worksheets(ProductSheetName)
Set productsList = productWS.Range(ProductRange)
Application.ScreenUpdating = False
For Each anyProduct In productsList
If Not IsEmpty(anyProduct) Then
If Trim(anyProduct) <> "" Then
For LC = LBound(uniqueList) To UBound(uniqueList)
If Trim(anyProduct) = uniqueList(LC) Then
Exit For ' found match, exit
End If
Next
If LC > UBound(uniqueList) Then
'new item, add it
uniqueList(UBound(uniqueList)) = Trim(anyProduct)
'make room for another
ReDim Preserve uniqueList(1 To UBound(uniqueList) + 1)
End If
End If
End If
Next ' end anyProduct loop
If UBound(uniqueList) > 1 Then
'remove empty element
ReDim Preserve uniqueList(1 To UBound(uniqueList) - 1)
End If
'clear out any previous entries in results column
If productWS.Range(ResultsCol & Rows.Count).End(xlUp).Row > 1 Then
productWS.Range(ResultsCol & 2 & ":" & _
productWS.Range(ResultsCol & Rows.Count).Address).ClearContents
End If
'list the unique items found
For LC = LBound(uniqueList) To UBound(uniqueList)
productWS.Range(ResultsCol & Rows.Count).End(xlUp).Offset(1, 0) = _
uniqueList(LC)
Next
'housekeeping cleanup
Set productsList = Nothing
Set productWS = Nothing
End Sub
I think your solution is a bit more tricky than it needs to be. Collecting unique ids becomes almost trivial is you use a Dictionary instead of a list. The added benefit is that a dictionary will scale much better than a list as your data set becomes larger.
The code below should provide you with a good starting point to get you going. For convenience's sake I used the reference from your post. So output will be on sheet2 to starting in cell B5 going down and the input is assumed to be on sheet1 cell B2 going down.
If you have any questions, please let me know.
Option Explicit
Sub ExtractUniqueEntries()
'enable microsoft scripting runtime --> tools - references
Dim unique_ids As New Dictionary
Dim cursor As Range: Set cursor = ThisWorkbook.Sheets("Sheet1").Range("B2") 'change as Required
'collect the unique ids
'This assumes that:
'1. ids do not contain blank rows.
'2. ids are properly formatted. Should this not be the could you'll need to do some validating.
While Not IsEmpty(cursor)
unique_ids(cursor.Value) = ""
Set cursor = cursor.Offset(RowOffset:=1)
Wend
'output the ids to some target.
'assumes the output area is blank.
Dim target As Range: Set target = ThisWorkbook.Sheets("Sheet2").Range("B5")
Dim id_ As Variant
For Each id_ In unique_ids
target = id_
Set target = target.Offset(RowOffset:=1)
Next id_
End Sub
A small modification will do it; the key is to define the ProductRange.
Sub ExtractUniqueEntries()
Const ProductSheetName = "Sheet1" ' change as appropriate
Dim ProductRange
ProductRange = "B2:B" & Range("B" & Cells.Rows.Count).End(xlUp).Row
Const ResultsCol = "E"
Dim productWS As Worksheet
Dim uniqueList() As String
Dim productsList As Range
Dim anyProduct
Dim LC As Integer
ReDim uniqueList(1 To 1)
Set productWS = Worksheets(ProductSheetName)
Set productsList = productWS.Range(ProductRange)
Application.ScreenUpdating = False
For Each anyProduct In productsList
If Not IsEmpty(anyProduct) Then
If Trim(anyProduct) <> "" Then
For LC = LBound(uniqueList) To UBound(uniqueList)
If Trim(anyProduct) = uniqueList(LC) Then
Exit For ' found match, exit
End If
Next
If LC > UBound(uniqueList) Then
'new item, add it
uniqueList(UBound(uniqueList)) = Trim(anyProduct)
'make room for another
ReDim Preserve uniqueList(1 To UBound(uniqueList) + 1)
End If
End If
End If
Next ' end anyProduct loop
If UBound(uniqueList) > 1 Then
'remove empty element
ReDim Preserve uniqueList(1 To UBound(uniqueList) - 1)
End If
'clear out any previous entries in results column
If productWS.Range(ResultsCol & Rows.Count).End(xlUp).Row > 1 Then
productWS.Range(ResultsCol & 2 & ":" & _
productWS.Range(ResultsCol & Rows.Count).Address).ClearContents
End If
'list the unique items found
For LC = LBound(uniqueList) To UBound(uniqueList)
productWS.Range(ResultsCol & Rows.Count).End(xlUp).Offset(1, 0) = _
uniqueList(LC)
Next
'housekeeping cleanup
Set productsList = Nothing
Set productWS = Nothing
End Sub
This program aims to compare two named ranges in two sheets. If the cells values are found in both sheets it highlights cells in green otherwise in red.
In my code below, I get a logical error.
I compare the results in the two sheets manually but I get totally different results.
Public Sub FindBtn_Click()
range1Name = namedRange1TxtBox
range2Name = namedRange2TxtBox
sheet1Name = Sheet1txt
sheet2Name = Sheet2txt
Dim range1No(), range2No() As Variant
range1No() = Range(range1Name)
range2No() = Range(range2Name)
Dim i, j As Integer
Dim cell As Variant 'Range
For i = LBound(range1No()) To UBound(range1No())
For j = LBound(range2No()) To UBound(range2No())
Set cell = Worksheets(sheet1Name).Range(range1Name).Find(what:=Worksheets(sheet2Name).Range(range2Name).Cells(i, 1).Value, lookat:=xlWhole)
If Not cell Is Nothing Then ' if jde cell value is found in tops then green jde cell
Worksheets(sheet1Name).Range(range1Name).Cells(i, 1).Interior.ColorIndex = 4
Else
Worksheets(sheet1Name).Range(range1Name).Cells(i, 1).Interior.ColorIndex = 3
End If
Application.StatusBar = "Progress: " & i & " of " & UBound(range1No()) '& Format(i / 9331, "%")
Next j
Next i
Without spending a while on in, I'm not too sure what's actually wrong with your code. But how about doing it this way (I substituted strings in the variables so I could make it work locally).
Public Sub FindBtn_Click()
range1Name = "firstrange"
range2Name = "secondrange"
sheet1Name = "Sheet1"
sheet2Name = "Sheet2"
Dim range1cell As Range
Dim range2cell As Range
For Each range1cell In Range(range1Name)
range1cell.Interior.ColorIndex = 3
For Each range2cell In Range(range2Name)
If range1cell.Value = range2cell.Value Then
range1cell.Interior.ColorIndex = 4
Exit For
End If
Next range2cell
Next range1cell
End Sub
On looking closer, I notice that while you're looping through values of j you don't seem to refer to j anywhere else.
the following code solved my problem basicly I don't know how to use the find function properly. below a code that does the job :)
Thanks :)
Dim cell1 As Range, cell2 As Range
Dim add1 As Variant
With Worksheets("JDE").Range("JS_No")
For Each cell2 In Worksheets("TOPS").Range("TechID")
Set cell1 = .Find(cell2, LookIn:=xlValues)
If Not cell1 Is Nothing Then
add1 = cell1.Address
Do
cell1.Interior.ColorIndex = 4
cell2.Interior.ColorIndex = 4
Application.StatusBar = "Processing: " & add1
Loop While Not cell1 Is Nothing And cell1.Address <> add1
End If
Next cell2
End With
I'm trying to adapt the Sub + Function from this thread to my need:
write all possible combinations
Tim Williams solution.
It works fine since all columns have at least 2 values. I'm after if there is a workaround to make it work even if some of the columns have just one value in it.
In the Sub command I could change to
col.Add Application.Transpose(sht.Range(Cells(3, c.Column), Cells(Rows.Count, c.Column).End(xlUp)))
and it goes fine.
But the Function is crashing at this line:
ReDim pos(1 To numIn)
just when processing the column that has just one value in it.
Thaks in advance for any help.
I have a more elegant solution with following assumptions:
The data and write to cells are on the same activesheet
Start combination from a cell you specify and going downward then right
Stops going rightward as soon as the cell of the same row is empty
writes the combination from a cell you specify going downwards
Screenshots after the code (Bug fixed on 1 row only on a data column):
Private Const sSEP = "|" ' Separator Character
Sub ListCombinations()
Dim oRngTopLeft As Range, oRngWriteTo As Range
Set oRngWriteTo = Range("E1")
Set oRngTopLeft = Range("A1")
WriteCombinations oRngWriteTo, oRngTopLeft
Set oRngWriteTo = Nothing
Set oRngTopLeft = Nothing
End Sub
Private Sub WriteCombinations(ByRef oRngWriteTo As Range, ByRef oRngTop As Range, Optional sPrefix As String)
Dim iR As Long ' Row Offset
Dim lLastRow As Long ' Last Row of the same column
Dim sTmp As String ' Temp string
If IsEmpty(oRngTop) Then Exit Sub ' Quit if input cell is Empty
lLastRow = Cells(Rows.Count, oRngTop.Column).End(xlUp).Row
'lLastRow = oRngTop.End(xlDown).Row ' <- Bug when 1 row only
For iR = 0 To lLastRow - 1
sTmp = ""
If sPrefix <> "" Then
sTmp = sPrefix & sSEP & oRngTop.Offset(iR, 0).Value
Else
sTmp = oRngTop.Offset(iR, 0).Value
End If
' No recurse if next column starts empty
If IsEmpty(oRngTop.Offset(0, 1)) Then
oRngWriteTo.Value = sTmp ' Write value
Set oRngWriteTo = oRngWriteTo.Offset(1, 0) ' move to next writing cell
Else
WriteCombinations oRngWriteTo, oRngTop.Offset(0, 1), sTmp
End If
Next
End Sub
I have a spread sheet that look like so:
Group | Name | Title
-----------------------------------
X WS -
X DH -
X M -
X DH -
X WS -
I want to loop through all the cells in name and replace the initial there with their full name in addition to adding the correct title. My script is failing to accurately compare the strings and go into the if-statement:
Sub enterNameAndTitle()
lastCell = InputBox("Last cell")
rInitials = InputBox("Initials")
rFullName = InputBox("Full Name")
rTitle = InputBox("Title")
Dim cell As Range
For Each cell In Range("b2:b" & lastCell).Cells
MsgBox (cell.Text & " : " & rInitials)
If StrComp(UCase(cell.Value), UCase(rInitials)) = 0 Then
cell.Value = rFullName
ActiveSheet.Cells(cell.Row, cell.Column + 1).Value = rTitle
End If
Next cell
End Sub
So I first collect the data and then loop through all the values. Does anyone know what I am doing incorrectly? Why doesn't it compare the string accurately?
I don't see anything wrong, but there are 2 things I would try
One is to use TRIM to make sure neither string has leading or trailing blanks
The 2nd is to change the if to if(ucase(trim(cell.value))=ucase(trim(rInitials)))
The problem was one of differing types and the only way that seemed to work for me was to re-cast both variables as type String using CStr()
Sub enterNameAndTitle()
Dim lastCell As String
lastCell = InputBox("Last cell")
'Cast to string
Dim rInitials As String
rInitials = CStr(InputBox("Initials"))
Dim rFullName As String
rFullName = InputBox("Full Name")
Dim rTitle As String
rTitle = InputBox("Title")
Dim cell As Range
For Each cell In Range("b2:b" & lastCell).Cells
Dim cellText As String
'Cast to string
cellText = CStr(cell.Text)
If (Trim(UCase(cell.Value)) = Trim(UCase(rInitials))) Then
MsgBox ("test1")
cell.Value = rFullName
ActiveSheet.Cells(cell.Row, cell.Column + 1).Value = rTitle
End If
Next cell
End Sub