I am trying to make a loop that prints every value between two cells in a row into a single column. I would also like it to skip/ignore non integer values.
For example: Cell A5 contains 5673 and Cell B5 contains 5677. Therefore the macro would output 5673, 5674, 5675, 5676, and 5677.
I have found some useful examples for looping through each row and printing each value, but have not been able to combine the two.
To print each value between the two numbers:
[D1] = [A1].Value
ato = [B1].Value
[D1].DataSeries Rowcol:=xlColumns, Type:=xlLinear, Step:=1, Stop:=ato
To loop through every row:
LR = Range("A" & Rows.Count).End(xlUp).Row
For j = 1 To LR
Cells(j, 1).Offset(0, 2).Value = ***Every cell value between Cells(j, 1) and Cells(j, 2)***
Next j
Before:
Desired after:
Try this. You can use SpecialCells to pick out the numerical cells, and Fill to produce the intervening sequences.
Sub x()
Dim rA As Range, rCell As Range
For Each rA In Columns(1).SpecialCells(xlCellTypeConstants, xlNumbers).Areas
For Each rCell In rA
Range("D" & Rows.Count).End(xlUp)(2).Value = rCell.Value
Range("D" & Rows.Count).End(xlUp).DataSeries Rowcol:=xlColumns, Step:=1, Stop:=rCell.Offset(, 1), Trend:=False
Next rCell
Next rA
End Sub
If you will always have these 2 columns, then you may use this code
for j = 1 to 2:for i = 1 to cells(rows.count,j).end(xlup).row
if isnumeric(cells(i,j)) then cells(rows.count,4).end(xlup).offset(1,0) = cells(i,j)
next:next
bear in mind that it will post everysingle number, if you need to delete duplicates, you may do it using range.removeduplicate
Loop through the range cell by cell; test for IsNumeric and Duplicate values. Note: this is just a test code, you should always add workbook and worksheet references
For i = 1 To Cells(Rows.Count, 1).End(xlUp).Row
For j = 1 To 2
If IsNumeric(Cells(i, j)) And Cells(i, j).Offset(, 1).Value <> Cells(i, j).Value Then
If IsEmpty(Cells(1, 4).Value) Then
Cells(1, 4) = Cells(i, j)
Else: Cells(Rows.Count, 4).End(xlUp).Offset(1) = Cells(i, j)
End If
End If
Next j
Next i
Related
I have rows of data
Some rows are blank apart from Column C
If Column A is blank then I would like to concatenate Column C with column C from the row above - then delete the row. There could be situations where Column A has 2 or more blank rows, so that would require all those rows in Column C to be merged together
This is the code I used, but I keep getting a mismatch error - not sure where I am going wrong, but the error highlights the line with the offsets in
Sub Merge()
Dim rng As Range
Set ws = Worksheets("test") 'Change your sheet name
Set rng = ws.Range("A1:M5600")
With ws
For i = rng.Rows.Count To 1 Step -1
If .Cells(i, 1) = "" Then
.Cells(i, 3).Offset(-1) = .Cells(i, 3).Offset(-1) & .Cells(i, 3)
.Rows(i).EntireRow.Delete
End If
Next
End With
End Sub
Maybe my comment is not very clear, this is what I mean:
If .Cells(i, 1).Value = "" Then
.Cells(i, 3).Offset(-1).Value = .Cells(i, 3).Offset(-1).Value & ", " & .Cells(i, 3).Value
(I also added ", " for readability purposes)
Edit after comment
.Cells(i, 3).Offset(-1).Value = CStr(.Cells(i, 3).Offset(-1).Value) & ", " & CStr(.Cells(i, 3).Value)
Is that better?
I have these cells:
Strings in cells
I would like to return specific parts of these strings - the "...bar" and "also csatlakozas" or "hatso csatlakozas" - to other cells.
Try below code, this should get you started:
Sub ExtractMatchingCells()
'Define in which column data is located
col = 1
lastRow = Cells(Rows.Count, col).End(xlUp).Rows
For i = 1 To lastRow
' Extract cell value to cell to the right
If InStr(0, Cells(i, col), "bar (also csatlakozas)") > 0 Or InStr(0, Cells(i, col), "bar (hatso csatlakozas)") Then
Cells(i, col + 1) = Cells(i, col)
End If
Next
End Sub
Trying to loop two columns and put result into one column.
1) looping is incorrect (no hits = wrong)
2) printing puts result into two different columns ("O" +7 from H and "R" +7 from K).
Private Sub FindValueKH_JN()
'New column O (no 15)
'Find if value starting in column H (no8) is between 207100-208100
'AND if value starting in column K (no11) is between 12700-12729,
' then T2J in column O, else T2N in O
Range("O1").Select
Selection.EntireColumn.Insert , CopyOrigin:=xlFormatFromLeftOrAbove
ActiveCell.FormulaR1C1 = "T2 er Ja eller Nei"
Dim loopRange As Range
'From H to new column O is +7 columns
lastrow1 = ActiveSheet.Cells(Rows.Count, "H").End(xlUp).Row
'From K to new column O is +4 columns
lastrow2 = ActiveSheet.Cells(Rows.Count, "K").End(xlUp).Row
'loop columns H and K
Set loopRange = Union(Range("H2:H" & lastrow1), Range("K2:K" & lastrow2))
For Each cell In loopRange
If Left(cell.Value, 6) >= 207100 And Left(cell.Value, 6) <= 208100 And _
Left(cell.Value, 5) >= 12700 And Left(cell.Value, 5) <= 12729 Then
cell.Offset(0, 7).Value = "T2J"
Else: cell.Offset(0, 7).Value = "T2N"
End If
Next cell
End Sub
Your references are incorrect, and this is why you are not getting any hits. You want to check two separate columns for specific values, but instead are just looking in one single cell for both conditions:
For Each cell In loopRange will loop through every cell in your defined loopRange range, which contains both columns.
You'd have to change your code so it loops through just a single column instead, like the following
Dim loopRange As Range
lastrow = ActiveSheet.Cells(Rows.Count, "H").End(xlUp).Row 'From H to new column O is +7 columns
Set loopRange = Range("H2:H" & lastrow1) 'loop columns H
For Each cell In loopRange
If Left(cell.Value, 6) >= 207100 And Left(cell.Value, 6) <= 208100 And Left(cell.Offset(, 3).Value, 5) >= 12700 And Left(cell.Offset(, 3).Value, 5) <= 12729 Then
cell.Offset(0, 7).Value = "T2J"
Else: cell.Offset(0, 7).Value = "T2N"
End If
Next cell
In your If-statement, you are checking the content of a single cell and your If-statement can never be true. With your Union-statement, you will get a Range with all cells of Col H and all cells of Col K, and in the loop you are checking all cells that are either in H or in K.
So your If hits, for example, Cell H2 and you are checking if the content is > 207100 and in the same moment < 12729.
What you probably want is to loop over all cells if column H, check it's value together with the value of the cell in column K of the same row.
I assume your cells contain a string starting with a number but holds also some characters. I would advice that you write the values into intermediate variables, makes it much easier to debug. You are using the left-function which will give you the first 6 (resp. 5) characters. The result is still a string (even if it contains only digits), and you compare it to a number, and that's not a good idea because now VBA has to do some implicit conversions, and that may lead to unexpected results. You should use the Val-function to convert a string into a numeric value.
As already mentioned in the comments, never work implicit on the so called Active Worksheet. Specify explicitly the worksheet you want to work with.
One question: Why do you use the strange syntax for the Else-statement. The : means that you put a second statement into a line. It is much more readable to omit the : and put the next statement(s) into separate lines.
Dim loopRange As Range, cell As Range, lastrow As Long
With ThisWorkbook.Sheets(1)
lastrow = .Cells(Rows.Count, "H").End(xlUp).row
Set loopRange = .Range("H2:H" & lastrow)
End With
For Each cell In loopRange
Dim valH As Long, valK As Long
valH = Val(Left(cell.Value, 6))
valK = Val(Left(cell.Offset(0, 3).Value, 6))
If valH >= 207100 And valH <= 208100 And valK >= 12700 And valK <= 12729 Then
cell.Offset(0, 7).Value = "T2J"
Else
cell.Offset(0, 7).Value = "T2N"
End If
Next cell
This is the macro i am using, it looks at a field (AS) and then depending on the number in that column it will create the same amount of rows underneath. So for example if AS has '4' it will create 4 rows containing the number 4.
I need an amendment to this so that these rows will show 1-4, 2-4, 3-4, 4-4
Sub addlabels()
Dim r As Long
For r = Cells(Rows.Count, 1).End(xlUp).Row To 2 Step -1
If Cells(r, "AS") > 1 Then
Cells(r, 1).EntireRow.Copy
Cells(r + 1, 1).EntireRow.Resize(Cells(r, "AS").Value - 1).Insert shift:=xlDown
End If
Next r
End Sub
Here is an example image of how i need the column to display at the moment it just simply copies from the top field http://i.stack.imgur.com/p8bl8.png
May be you can try like this:
Considering the field("AS") is in cell a1 i've used the following code:
Sub addinglabels()
Dim i As Integer
cellvalue = ActiveSheet.Range("A1").Value
If (cellvalue > 1) Then
For i = 1 To cellvalue
Cells(i + 1, 1).Value = i & "--" & cellvalue
Next i
End If
End Sub
I'm trying to work out how to write a Macro to replace the current Excel formula I'm using. I've tried experimenting with cell values and offsets but my knowledge of VBA is minimal. What I need it to do is to turn a single column list like this:
Cell 1
Cell 2
Cell 3
Cell 4
Cell 5
Cell 6
Into a two-column list like this:
Cell 1 Cell 2
Cell 3 Cell 4
Cell 5 Cell 6
I feel as if it should be pretty simple to achieve, but I want to avoid blank spaces and a loop will probably be required as the length of the list is likely to change each time the macro is run. Can anybody help?
I managed to work out how to do it:
Sub splitColumn()
Range("A1").Select
Do
ActiveCell.Offset(1, 0).Select
If IsEmpty(ActiveCell.Offset(-1, 1)) Then
ActiveCell.Offset(-1, 1).Value = ActiveCell
ActiveCell.EntireRow.Delete
End If
Loop Until IsEmpty(ActiveCell)
End Sub
May be you can try with the following code:
But its a bit too long...I think it may help you in providing some ideas...
Sub Splitting()
Dim i, j, k, l As Integer
RowCount = ThisWorkbook.Sheets("Sheet1").UsedRange.Rows.Count
For i = 1 To RowCount Step 2
For j = 1 To 1
Cells(i, j + 1).Value = Cells(i, j).Value
Cells(i, j + 2).Value = Cells(i + 1, j).Value
Next j
Next i
Call Removeblanks
End Sub
Sub Removeblanks()
RowCount = ThisWorkbook.Sheets("Sheet1").UsedRange.Rows.Count
For i = 1 To RowCount
For j = 1 To 1
If (Cells(i, j + 1).Value = "") Then
Cells(i, j + 1).Delete
Cells(i, j + 2).Delete
End If
Next j
Next i
End Sub