I have coded following macro, it is working when I save the values to immediate window, but don't know how to populate the values, delimited with "," into one cell. Basically I look for "Active" in a column, and if found, go 4 cells to the left and take the info from there...
Could you help please?
Dim Active() As Variant
Dim i
ReDim Active(Range("G9:G24").Cells.Count)
For Each Zelle In Range("G9:G24")
If InStr(1, Zelle, "Active") <> 0 Then
Active(i) = Zelle.Offset(0, -4)
End If
i = i + 1
Next Zelle
For i = LBound(Active) To UBound(Active)
If Trim(Active(i)) <> "" Then
Debug.Print Active(i)
End If
Next i
End Sub
Add the following
Dim s As String
Then rewrite the loop like this:
For i = LBound(Active) To UBound(Active)
If Trim(Active(i)) <> "" Then
s = s & IIf(Len(s)>0, ",", "") & trim(Active(i))
End If
Next i
Then you can assign s to a cell.
you can greatly shorten your code by looping through wanted range cells corresponding to not-blank cells only in column C
Dim Zelle As Range
Dim resultStrng As String
For Each Zelle In Range("G9:G24").Offset(,-4).SpecialCells(xlCellTypeConstants) '<--| loop through not blank cell in range 4 columns to the left of G9:G24
If InStr(1, Zelle.Offset(, 4), "Active") <> 0 And Trim(Zelle) <> "" And Instr(resultStrng, Trim(Zelle)) =0 Then resultStrng = resultStrng & Trim(Zelle) & "," '<--| update your result string whenever current cell has a character and its 4 columns to the right offset cell meets the "Active" criteria
Next Zelle
If resultStrng <> "" Then resultStrng = Left(resultStrng, Len(resultStrng) - 1) '<-- remove the last comma from 'resultStrng'
Related
I have a three columns in excel with data such as
section1 section2 section3
no no er3
er1 no er3
no no no
how to write macros to Combine the data in the on column such as:
section_error
er3
er1,er3
no
So if there are only "no" then it should be once "no"
if there is something else besides "no", like "er1"or "er3" then only list of others signs.
it is not exactly to join or to CONCATENATE (
So, this might be a bit overkill depending on how many rows you have. But, using arrays is going to be a lot faster if you start getting up in the thousands.
Anyway, we define two named ranges, input and output. We then place the values of the input range into an array.
We loop through the array, checking the values of those spots in the array (which corresponds to the values in the cells now). When we find something, we append that something to the end of our output value for that row. When we don't find anything, we set that value to no.
At the end, we set the values of the output range (resized for our array) equal to our output array values.
Make sure you define those named ranges (and change their names too!).
Let me know if you have questions.
Option Explicit
Sub combineColumns()
Dim combineRange As Range, pasteRange As Range
Dim inputArr() As Variant, outputArr() As Variant, i As Long, j As Long, numberOfRows As Long
Dim currentOutputvalue As String
'Named range with values to combine, don't include header
Set combineRange = Range("yourNamedRangeToCombineHere")
'only need to set the top of the range to paste
Set pasteRange = Range("theCellAtTheTopOfWhereYouWantToPaste")
'put the values of the range you want to combine into the input array
inputArr = combineRange.Value2
'find the size of the array
numberOfRows = UBound(inputArr, 1)
'dimension the output array, same number of rows, but only one column
ReDim outputArr(1 To numberOfRows, 1 To 1)
'loop through our rows
For i = 1 To numberOfRows
'set the current output value to a blank
currentOutputvalue = ""
'loop through our three columns
For j = 1 To 3
'if cell value is not no, append the value to the end of current output value
'also append a comma
If inputArr(i, j) <> "no" Then
currentOutputvalue = currentOutputvalue & inputArr(i, j) & ","
End If
Next
If currentOutputvalue = "" Then
'all columns in this row were "no", so change value to "no"
currentOutputvalue = "no"
Else
'there was at least one not no
'trim off the end comma
currentOutputvalue = Left(currentOutputvalue, Len(currentOutputvalue) - 1)
End If
'assign the value to the spot in the array
outputArr(i, 1) = currentOutputvalue
Next
'resize the pasterange to the size of the array, and
'set the values of the range to those in the output array
pasteRange.Resize(numberOfRows, 1).Value2 = outputArr
End Sub
Here's a macro solution, just looping through the rows/columns:
Sub Test()
Dim i As Long, j As Long, lastrow As Long
Dim mystring As String
lastrow = Worksheets("ICS Analysis").Cells(Worksheets("ICS Analysis").Rows.Count, 1).End(xlUp).Row
For i = 2 To lastrow
For j = 1 To 3
If InStr(Worksheets("ICS Analysis").Cells(i, j).Value, "er") > 0 Then
If mystring = "" Then
mystring = Worksheets("ICS Analysis").Cells(i, j).Value
Else
mystring = mystring & "," & Worksheets("ICS Analysis").Cells(i, j).Value
End If
End If
Next j
If mystring <> "" Then
Worksheets("ICS Analysis").Cells(i, 4).Value = mystring
mystring = ""
Else
Worksheets("ICS Analysis").Cells(i, 4).Value = "no"
End If
Next i
End Sub
I'm developing a worksheet users can fill out to generate a file that can be uploaded into SAP.
The worksheet will generate a mass upload of individual entries. Users will be asked to provide attributes for each line item they are requesting, which may vary based on the selection made (i.e. one row may have 5 attributes while the next may have 7).
I want to write a macro that will look at each row, starting from the top, and concatenate only the attribute columns (which are separated by two other columns in each instance) which are not blank and use a delimiter between each field.
I've been able to use some code I found through Microsoft to get the looping done (see below), but I can't figure out how to have the concatenate stop when a column is blank and then move to the next row.
Sub Submit()
Range("C2").Activate
Do While ActiveCell <> ""
ActiveCell.Offset(0, 21).FormulaR1C1 = _
ActiveCell.Offset(0, 0) & "-" & ActiveCell.Offset(0, 3) & "-" &
ActiveCell.Offset(0, 6) & "-" & ActiveCell.Offset(0, 9) & "-" & ActiveCell.Offset(0, 12) & "-" & ActiveCell.Offset(0, 15) & "-" & ActiveCell.Offset(0, 18)
ActiveCell.Offset(1, 0).Select
Loop
End Sub
Right now, this code will take a five attribute entry and leave me with "1-2-3-4-5--", when I really want it to show up as "1-2-3-4-5".
Any thoughts on how I can go about doing this? Eventually, I want to be able to store those strings and populate them in a new workbook with some other information copied over from the original workbook.
Untested:
Sub Submit()
Dim c As Range, c2 As Range, v as String
Set c = Range("C2")
Do While c.Value <> ""
Set c2 = c
v = ""
Do While c2.value <> ""
v = v & IIf(v <> "", "-", "") & c2.value
Set c2 = c2.offset(0, 3)
Loop
c.offset(0, 21).Value = v
Set c = c.Offset(1, 0)
Loop
End Sub
This is a quick answer, so may not have everything you're after:
Public Function Submit(Target As Range) As String
Dim sFinalOutput As String
Dim rCell As Range
'Cylce through each cell in your range.
For Each rCell In Target
'Look at the column number divided by 3 - if it's 0 then carry on.
If rCell.Column Mod 3 = 0 Then
If rCell.Value2 <> "" Then
'Grab the value from the cell and add it to the final output.
sFinalOutput = sFinalOutput & "-" & rCell.Value2
End If
End If
Next rCell
Submit = sFinalOutput
End Function
Use it in a formula such as: =submit(C4:L4)
I am new to this. I am trying to find the lowest value in a cell with multiple values inside. For example,
48
44.50
41.00
37.50
I am trying to find 37.50. What should be the code for it?
Thanks
Based on your posted example:
Sub FindMin()
Dim s As String, CH As String
Dim wf As WorksheetFunction
Dim bry() As Double
Set wf = Application.WorksheetFunction
s = ActiveCell.Text
CH = Chr(10)
ary = Split(s, CH)
ReDim bry(LBound(ary) To UBound(ary))
For i = LBound(ary) To UBound(ary)
bry(i) = CDbl(ary(i))
Next i
MsgBox wf.Min(bry)
End Sub
This assumes that there is a hard return (ASCII-10) between the fields in the cell.
EDIT#1:
To make it into a function, remove the sub and replace with:
Public Function FindMin(r As Range) As Variant
Dim s As String, CH As String
Dim wf As WorksheetFunction
Dim bry() As Double
Set wf = Application.WorksheetFunction
s = r.Text
CH = Chr(10)
ary = Split(s, CH)
ReDim bry(LBound(ary) To UBound(ary))
For i = LBound(ary) To UBound(ary)
bry(i) = CDbl(ary(i))
Next i
FindMin = wf.Min(bry)
End Function
EDIT#2:
based on your comment, here is an example of input vs output:
Note that all the values are in a single cell and the values are separated by hard returns rather than spaces.
By code with same cell and a " " as delimiter to break
temp = Range("A1").Value
temp = Split(temp, " ")
Low = CInt(temp(0))
For i = 0 To UBound(temp) - 1
If CInt(temp(i)) < Low Then Low = CInt(temp(i))
Next
Range("a2").Value = Low
if they are in a range you can use a formula
=MIN(A1:A4)
This question is pretty close to one previously asked:
VBA/EXCEL: extract numbers from one cell that contained multiple values with comma
If you take the code from that answer and replace the comma with whatever is separating your values, you will be able to get access to them in VBA. Then you can write code to find the minimum.
You can make a macro to split the values for each cell you selected and then check for the highest value. And a quick check to make sure you are not parsing all the empty rows (when you selected a column).
The macro below will set the highest value in the next column.
Sub lowest()
Dim Values As Variant
Dim LowestValue As Double
Dim a As Range
Set a = Selection
For Each Row In a.Rows
For Each Cell In Row.Cells
LowestValue = -1
Values = Split(Cell.Value, Chr(10))
For Each Value In Values
If LowestValue = -1 Then
LowestValue = Value
ElseIf Value < LowestValue Then
LowestValue = Value
End If
Next
Cells(Cell.Row, Cell.Column + 1).Value = LowestValue
If IsEmpty(Cell.Value) Then GoTo EndLoop
Next Cell
Next Row
EndLoop:
End Sub
I want to iterate through data (simular to that shown below) that is stored in different cells and combine them into a single cell seperated by a new line (chr(10)). The amount of data that needs to be imported into one cell will change.
2991
19391
423
435
436
The code needs to iterate through the whole sheet regardless of any line breaks. The required format is:
2991 - all three cells would be combined into one cell in the next column to this one.
19391
423
-Line space, this will need to be taken into account and is the seperator of data.
26991 - all four cells would be combined into one cell in the next column to this one.
19331
424
6764
Below is what I have got so far, it takes the column to the left of the current row and combines it, which is wrong.
Sub ConcatColumns()
Do While ActiveCell <> "" 'Loops until the active cell is blank.
ActiveCell.Offset(0, 1).FormulaR1C1 = _
ActiveCell.Offset(0, -1) & chr(10) & ActiveCell.Offset(0, 0)
ActiveCell.Offset(1, 0).Select
Loop
End Sub
You can achieve the above with this code
Sub Main()
Dim i As Long
Dim c As Range
For i = Range("A" & Rows.Count).End(xlUp).Row To 1 Step -1
Dim strBuilder As String
Set c = Range("A" & i)
If Not IsEmpty(c) And i <> 1 Then
strBuilder = c & Chr(10) & strBuilder
ElseIf i = 1 Then
strBuilder = c & Chr(10) & strBuilder
c.Offset(0, 1) = Left(strBuilder, Len(strBuilder) - 1)
strBuilder = vbNullString
Else
c.Offset(1, 1) = Left(strBuilder, Len(strBuilder) - 1)
strBuilder = vbNullString
End If
Next i
End Sub
I think this could be done using a UDF.
Something like
Public Function JoinValues(rng As Range) As String
Dim cell As Range
Dim str As String
For Each cell In rng
If cell.Value <> "" Then
str = str & cell.Value & Chr(10)
End If
Next cell
If Len(str) > 1 Then JoinValues = Left(str, Len(str) - 1)
End Function
Then usage would be =JoinValues(A1:A10) in a cell to join values. You would also have to change cell formatting in the target cell to allow wrapping text for this to work properly.
Assuming your values start in cell A2 enter
=IF(A1="",joinvalues(OFFSET(A2,0,0,MATCH(TRUE,INDEX(ISBLANK(A2:A10000),0,0),0)-1)),"")
in B2 and drag the function down.
I'm trying to write an application that takes a report (Excel worksheet), manipulates a row, then goes to the next row, then the next row, etc., then exits the Do Until loop once the first two cells in the next row are empty (indicating that there are no more rows to process), like so:
Imports Excel = Microsoft.Office.Interop.Excel
Dim MSExcel As New Excel.Application
MSExcel.Visible = True
Dim WorkbookA As Excel.Workbook
Dim WorksheetA As Excel.Worksheet
Dim i As Integer = 2 'Skipping header row
Dim Split() As String
Dim SomeStrings() As String = {"StringA", "StringB"} 'etc... an array of strings
WorkbookA = MSExcel.Workbooks.Open(TextBox1.Text)
WorksheetA = WorkbookA.Sheets.Item(1)
Do Until WorksheetA.Cells(i, 1).Value = "" And WorksheetA.Cells(i, 2).Value = ""
'~~If Column A cell does not contain 'valueA' or Column E cell does not contain 'valueB', delete the row
Do Until InStr(WorksheetDisplay.Cells(i, 1).Value, "ValueA") <> 0 And InStr(WorksheetDisplay.Cells(i, 5).Value, "ValueB") <> 0 _
And InStr("somenumbershere", Strings.Left((WorksheetDisplay.Cells(i, 3).Value), 1)) <> 0 'Only keeps entries that begin with a certain number
WorksheetDisplay.Rows(i).Delete() 'Otherwise we delete the row
Loop
For Each Str As String In SomeStrings
If Str = WorksheetDisplay.Cells(i, 3).Value Then
Split = Strings.Split(WorksheetDisplay.Cells(i, 3).Value, " ")
WorksheetDisplay.Cells(i, 3).Value = Split(0) & " some text here"
End If
Next
i = i + 1
Loop
However the program never stops running.
Any idea why?
In your inner do until..loop where you are checking for three different conditions, if all 3 of those conditions are not met, your code will keep deleting the top row of the worksheet. This causes Excel to keep adding rows to the bottom of the worksheet.
So, this inner do loop has the potential to run forever, preventing the outer do loop from ever evaluating the existence of blank cells. A better arrangement of logic might be:
Do Until WorksheetA.Cells(i, 1).Value = "" And WorksheetA.Cells(i, 2).Value = ""
If InStr(WorksheetDisplay.Cells(i, 1).Value, "ValueA") <> 0 And InStr(WorksheetDisplay.Cells(i, 5).Value, "ValueB") <> 0 _
And InStr("somenumbershere", Strings.Left((WorksheetDisplay.Cells(i, 3).Value), 1)) <> 0 'Only keeps entries that begin with a certain number
WorksheetDisplay.Rows(i).Delete() 'Otherwise we delete the row
'Decrement i so that the row that used to be beneath the row just deleted is not skipped.
i = i - 1
Else
For Each Str As String In SomeStrings
If Str = WorksheetDisplay.Cells(i, 3).Value Then
Split = Strings.Split(WorksheetDisplay.Cells(i, 3).Value, " ")
WorksheetDisplay.Cells(i, 3).Value = Split(0) & " some text here"
End If
Next
End If
i = i + 1
Loop
I haven't run this code, since I don't know what kind of dataset you have to test against; but basically, if you delete a row, you need to get back to the outer do loop to check if you have run out of data, and stop execution if you have.