I am trying to copy and paste a range that includes blank cells into a single column on another sheet. I would like the blanks to be ignored.
Here is the Frankenstein code I am using at the moment it is slow and a bit cluncky picture included to better describe
I would like to expand on it so that multiple ranges can paste into the same column ie find the last cell with a value and paste into the next cell.
i have been told it should look something like this
'for r = 1 to 4
' for c = 1 to 8
' does rc have val,
' then copy to new sheet
' increment copy var
' increment c
' increment r
Sheets(Array("next record date")).Select
Range("G11:AZZ110").Select
If TypeName(Selection) = "Range" Then
If Selection.Count > 1 Then
If Selection.Count <= Selection.Parent.Rows.Count Then
vaCells = Selection.Value
ReDim vOutput(1 To UBound(vaCells, 1) * UBound(vaCells, 2), 1 To 1)
For j = LBound(vaCells, 2) To UBound(vaCells, 2)
For i = LBound(vaCells, 1) To UBound(vaCells, 1)
If Len(vaCells(i, j)) > 0 Then
lRow = lRow + 1
Sheets("Data").Select
Range("E2").Select
vOutput(lRow, 1) = vaCells(i, j)
Else
End If
Next i
Next j
Selection.ClearContents
Selection.Cells(1).Resize(lRow).Value = vOutput
End If
End If
End If
Thanks,
Jerome
Special cells constants method and paste transpose
Public Sub TransposeRange()
ThisWorkbook.Worksheets("next record date").Range("G11:AZ11").SpecialCells(xlCellTypeConstants, 23).Copy
ThisWorkbook.Worksheets("Data").Range("E2").PasteSpecial Paste:=xlValues, Transpose:=True
End Sub
Related
I am very new to VBA and have been stuck on this for a few days now.
I would like to compare H2 and H3. If equal then turn the cell green , If not equal then turn the cell red.
Once this is complete I would like to do the same for H4 and H5 , then H6 and H7...... all the way down to the last row of data.
Thank you in advance for your help .
How about something like this?
Sub ForLoopTest()
Dim loop_ctr As Integer
Dim Max As Integer
Max = ActiveSheet.UsedRange.Rows.Count
For loop_ctr = 1 To Max
If loop_ctr Mod 2 = 0 Then
row_below = loop_ctr + 1
If Cells(loop_ctr, "H") = Cells(row_below, "H") then
Cells(loop_ctr, "H").Interior.ColorIndex = 4
Cells(row_below, "H").Interior.ColorIndex = 4
Else
Cells(loop_ctr, "H").Interior.ColorIndex = 3
Cells(row_below, "H").Interior.ColorIndex = 3
End If
End If
Next loop_ctr
End Sub
I still feel like conditional formatting is they way to go here so that it's reactive to values changing in the worksheet, but if you are stuck on VBA as a solution here, something like this should do the trick:
Sub greenOrRed()
Dim lngRow As Long
For lngRow = 2 To Sheet1.Range("H2").End(xlDown).Row Step 2
If Sheet1.Range("H" & lngRow).Value = Sheet1.Range("H" & lngRow + 1).Value Then
Sheet1.Range("H" & lngRow & ":H" & lngRow + 1).Interior.ColorIndex = 4
Else 'didn't match
Sheet1.Range("H" & lngRow & ":H" & lngRow + 1).Interior.ColorIndex = 3
End If
Next lngRow
End Sub
You could also use a For Each loop to walk down the column which makes for some nice to read code. You just have to apply a test for Mod 2 on the row you are analyzing instead of using the very handy STEP 2 like in the For loop above:
Sub greenOrRed()
Dim rngCell As Range
For Each rngCell In Sheet1.Range("H:H").Cells
If rngCell.Value = "" And rngCell.Row > 1 Then Exit For
If rngCell.Row Mod 2 = 0 Then
If rngCell.Value = rngCell.Offset(1).Value Then
rngCell.Resize(2).Interior.ColorIndex = 4
Else
rngCell.Resize(2).Interior.ColorIndex = 3
End If
End If
Next rngCell
End Sub
And if you really want to condense it you can apply some boolean math to the setting of the interior.ColorIndex, but this only works because red and green are 1 colorindex value away from each other. Also the next person that adopts your code will hate you and won't think your nearly as clever as you think you are.
Sub greenOrRed()
Dim rngCell As Range
For Each rngCell In Sheet1.Range("H:H").Cells
If rngCell.Value = "" And rngCell.Row > 1 Then Exit For
If rngCell.Row Mod 2 = 0 Then rngCell.Resize(2).Interior.ColorIndex = 3 + Abs(rngCell.Value = rngCell.Offset(1).Value)
Next rngCell
End Sub
some other ways
another loop approach:
Sub CompareCells()
Dim i As Long
With Range("H2", Cells(Rows.Count,"H").End(xlUp)) ' reference column H cells from row 2 down to last not empty one
For i = 1 To .Count Step 2 ' loop through referenced range skipping every other row
With .Cells(i, 1) ' reference current cell
.Interior.Color = IIf(.Value2 = .Offset(1).Value2, vbGreen, vbRed) 'set current cell color with respect to below cell content
End With
Next
End With
End Sub
a no-loop approach:
Sub CompareCells()
With Range("H2", Cells(Rows.Count, "H").End(xlUp)) ' reference column H cells from row 2 down to last not empty one
With .Offset(, 1) ' reference referenced range 1 column to the right offset range. this is a "helpre" column
.FormulaR1C1 = "=IF(even(row())=row(),1,"""")" ' write 1's every two rows in referenced range
With .SpecialCells(xlCellTypeFormulas, xlNumbers) ' reference referenced range "numbered" rows
.Offset(, -1).Interior.Color = vbRed ' mark referenced range 1 column left offset in red
.FormulaR1C1 = "=IF(RC[-1]=R[1]C[-1],1,"""")" ' signal referenced range cells with 1 if corresponding 1 column to the left offset cell content equals its below cell content
.SpecialCells(xlCellTypeFormulas, xlNumbers).Offset(, -1).Interior.Color = vbGreen ' turn reference referenced range "numbered" cells color to green
End With
.ClearContents ' clear referenced "helper" column
End With
End With
End Sub
I am new to programming and |I would like some help with the following:
I need a code that when it reads in cells(x,3)="wall" then for every next row until it "hits" another element, that it to say until cells(x+1,3)<>"", it copies the values of cells A:E of that row to another sheet if these satisfy a specific condition. The code will somehow start like that:
If Cells(x, 3) = "wall" Then
Do Until Cells(x + 1, 2) <> ""
If Cells(x + 1, 4) <> "m2" Then
......
x=x+1
Loop
I would like some help with the part of the code in between.
Try the code below. Make sure that it's looking at the correct cells for your conditions.
Option Explicit
Sub copyCells()
'Some variables to keep track of where we are on the sheets
Dim x As Integer
Dim lastRow As Integer
Dim i As Integer
Sheets("Sheet1").Select
Range("A1").Select
'I used 18 rows in my test set. You'll want to change this to fit your data.
lastRow = 18
i = 1
For x = 1 To lastRow
'Check for the first condition
If Cells(x, 3) = "wall" Then
'Move to the next row
x = x + 1
'Check that this is a row we want to copy
'and we haven't reached the end of our data
Do While Cells(x, 2) = "" And x < lastRow
'Check the second condition
If Cells(x, 4) <> "m2" Then
'Copy and paste to the second sheet
Range("A" & x & ":E" & x).Copy
Sheets("Sheet2").Select
Range("A" & i).Select
ActiveSheet.Paste
'Increment i to keep track of where we are on the second sheet
i = i + 1
End If
'Go back to checking the first sheet
x = x + 1
Sheets("Sheet1").Select
Range("A" & x).Select
Loop
End If
Next x
Application.CutCopyMode = False
End Sub
I'm struggling to write the correct code to be able to Copy and Paste Values for non-blank values with matching criteria.
An example of what I'm trying to do can be seen here (Example)
What I would like the code to do is to take the values in the left hand range that are not blank, and paste the values into the right hand range where they match according to the labels in row A.
If the new values could paste as a highlighted color that would be helpful as well; however, my main struggle is mainly with the first part. (Picture of how it would look after the macro has run) - (Answer)
I have been able to figure this out by using excel formulas within my code; however, this is not ideal for the functionality of my workbook.
Thanks for the help! - It's much appreciated.
Update:
Sub Button2_Click()
Worksheets("Nielson").Range("AH3:CD9999").Formula = "=if(NOT(ISBLANK(vlookup($a3,Load!$P:$AD,Load!R$4,False))),iferror(vlookup($a3,Load!$P:$AD,Load!R$4,False),ch3),ch3)"
Worksheets("Nielson").Range("AH3:CD9999").Copy
Worksheets("Nielson").Range("CH3:CT9999").PasteSpecial xlPasteValues Worksheets("Nielson").Range("CH3:CT9999").Copy
Worksheets("Nielson").Range("AH3:CD9999").PasteSpecial xlPasteValues
End Sub
(code posted as comment by OP)
This can help you. Is a modification of this code.
Private Sub Button2_Click()
Dim vReplacementArray() As Variant
Dim iLastRowReplacements As Integer
Dim iLastRowData As Integer
Dim i As Integer, j As Integer, r As Integer, c As Integer
Dim ValToFind1 As String
iLastRowReplacements = Worksheets("Nielson").Cells(Rows.Count, 1).End(xlUp).Row
iLastRowData = Worksheets("Nielson").Cells(Rows.Count, 9).End(xlUp).Row
'Create an array with replacement data (left 6 columns in your example)
For i = 2 To iLastRowReplacements
ReDim Preserve vReplacementArray(1 To 6, 1 To i)
'You can loop here. I leave it hard-coded to make it clearer
vReplacementArray(1, i) = Worksheets("Nielson").Cells(i, 1).Value
vReplacementArray(2, i) = Worksheets("Nielson").Cells(i, 2).Value
vReplacementArray(3, i) = Worksheets("Nielson").Cells(i, 3).Value
vReplacementArray(4, i) = Worksheets("Nielson").Cells(i, 4).Value
vReplacementArray(5, i) = Worksheets("Nielson").Cells(i, 5).Value
vReplacementArray(6, i) = Worksheets("Nielson").Cells(i, 6).Value
Next
For i = 2 To iLastRowData 'Scan all rows with data, starting in row 2 (row 1 for titles)
'Get values from column I (ValToFind1)
ValToFind1 = Worksheets("Nielson").Cells(i, 9).Value
'Find those to values in the array, and write the replacement in their respective column
For c = 1 To UBound(vReplacementArray, 2)
If (vReplacementArray(1, c) = ValToFind1) Then
For j = 1 To 5 'The five columns (J to N in your example)
If (vReplacementArray(j + 1, c) <> "") Then 'if there is a value
Worksheets("Nielson").Cells(i, 9 + j).Value = vReplacementArray(j + 1, c)
Worksheets("Nielson").Cells(i, 9 + j).Interior.ColorIndex = 4
End If
Next j
End If
Next c
Next i
End Sub
I'm learning VBA and have some problems
What I have is a list of date:
picture1
What I want to do is add 3 meals for everyday like this
picture2
I have recorded a macro which can achieve this:
Sub InsertMeal()
ActiveCell.EntireRow.Insert
ActiveCell.EntireRow.Insert
ActiveCell.Offset(0, 2).Select
ActiveCell.FormulaR1C1 = "Breakfast"
ActiveCell.Offset(1, 0).Select
ActiveCell.FormulaR1C1 = "Lunch"
ActiveCell.Offset(1, 0).Select
ActiveCell.FormulaR1C1 = "Dinner"
ActiveCell.Offset(-2, -2).Range("A1:A3").Select
Selection.Merge
End Sub
Now I want write a macro, which apply this InsertMeal() function to each cells in selected range.
This is what I wrote
Sub ApplyToAll()
For Each c In ActiveCell.CurrentRegion.Cells
Call InsertMeal
ActiveCell.Offset(1, 0).Select
Next
End Sub
The problem is, since I insert rows every time, the For loop doesn't work well. The loop never end. Now I don't know how to "keep the range" to make the loop work.
Please help if you know how to do this. Thank you, really appreciate.
There really is no need for two functions here. To amend your loop to do what you need, b/c you are adding rows, you will need to nest a small loop inside the other loop that works in you block of 3 ,Breakfast ,Lunch, and Dinner.
The code would look something like this, but you will have to amend the range to suit your purpose. For example
Sub dave()
Dim i As Long
Dim lastrow As Long
Dim j As Long
lastrow = Cells(Rows.Count, 1).End(xlUp).Row * 3
x = Array("Breakfast", "Lunch", "Dinner")
For i = 1 To lastrow
Cells(i + 1, 1).Resize(2).EntireRow.Insert
For j = 1 To 3
Cells(i + j - 1, 3).Value = x(j - 1)
Next j
Cells(i, 1).Resize(3).Merge: i = i + 2
Next i
End Sub
BTW, the lastrow will need to be multiplied by 3 as you are addeding rows, so the original lastrow will not reflect the actuall last row when finnished.
Sub RelativeFunc()
col = ActiveCell.Column
lastrow = Cells(Rows.Count, col).End(xlUp).Row
firstrow = Cells(1, col).End(xlDown).Row
rownum = lastrow - firstrow + 1
frownum = rownum * 3
x = Array("Breakfast", "Lunch", "Dinner")
For i = 1 To frownum
Cells(i + firstrow, col).Resize(2).EntireRow.Insert
For j = 1 To 3
Cells(firstrow + i - 1 + j - 1, col + 1).Value = x(j - 1)
Next j
Cells(firstrow + i - 1, col).Resize(3).Merge
i = i + 2
Next i
End Sub
I want to copy values from one column to another column (into the same row) if the cell contains the word IN and delete the original value. If not, the code should proceed to the next row and perform a new test. Thus the cell in the target column will remain empty.
When I run the code in Excel nothing happens, so I don't know what is wrong.
Ideally the code should jump to the next column (8) and do the same search and paste the value into the same column (5) when it is done with the first column, but this I haven't started with yet. So I do appreciate tips for that as well :)
Sub Size()
Dim i As Integer, a As String
i = 2
a = "IN"
Do While Cells(i, 7).Value <> ""
If InStr(Cells(i, 7), a) Then
'copying the value to another column but within the same row
Cells(i, 7).Copy Cells(i, 5)
Cells(i, 7).Clear
i = i + 1
Else
i = i + 1
End If
Loop
End Sub
I found out that my first cell in column 7 was empty and thus the Do While Cells(i, 7).Value <> "" wasn't working. Hence I'm refering to a different column that always contain data. Note that the solution code also jumps to the 2 next columns in order to search for the same word.
Sub Size()
Dim i As Integer, a As String
j = 0
i = 1
a = "IN"
Range("A1").Offset(i, 0).Select
For j = 0 To 2
Do Until Selection.Value = ""
If InStr(Range("G1").Offset(i, j).Value, a) Then
Range("E1").Offset(i, 0).Value = Range("G1").Offset(i, j).Value
Range("G1").Offset(i, j).Clear
i = i + 1
Range("A1").Offset(i, 0).Select
Else
i = i + 1
Range("A1").Offset(i, 0).Select
End If
Loop
i = 1
Range("A1").Offset(i, 0).Select
Next j
End Sub