I hope you can help. I have a piece of code below, and its working somewhat. I just need it to do more.
It currently looks along the first row from A1 to H1. If it finds a blank cell then it copies the cell value to the left of the blank cell, then pastes this value into the blank cell and then moves along.
As the range can change from day to day A1 to H1 will not suffice. I now need the code to look along the first row, until it finds the last cell with data in it then look for the blanks and start the copy and paste process.
I also need the code to then add a 2 to the pasted cell so that I can perform a pivot and differentiate between the copied cells and the pasted.
I have provided a picture below for better understanding. The end result should be that cell B2 contains the text 24 - Company: Hier 2 and E2 contains the text 07 - Product: Family Hier 2
My code is below and as always any and all help is greatly appreciated.
Pic 1
MY CODE
Public Sub BorderForNonEmpty()
Dim myRange As Range
Set myRange = Sheet1.Range("A1:H1")
For Each MyCell In myRange
If MyCell.Text = "" Then
MyCell.Offset(0, -1).Select
ActiveCell.Copy
ActiveCell.Offset(0, 1).PasteSpecial (xlPasteAll)
End If
Next
End Sub
Try the code below - the comments indicate what each important line is doing:
Option Explicit
Sub FillInHeaders()
Dim ws As Worksheet
Dim lngRowWithHeaders As Long
Dim rngHeader As Range
Dim rngCell As Range
' get a reference to your worksheet
Set ws = ThisWorkbook.Worksheets("SHeet1")
' set the row that the headers are on
lngRowWithHeaders = 2
' get the range from A1 to ??1 where ?? is last column
Set rngHeader = ws.Cells(lngRowWithHeaders, 1) _
.Resize(1, ws.Cells(lngRowWithHeaders, ws.Columns.Count) _
.End(xlToLeft).Column)
' iterate the range and look for blanks
For Each rngCell In rngHeader
' if blank then ...
If IsEmpty(rngCell.Value) Then
' get cell value from left and a 2
rngCell.Value = rngCell.Offset(0, -1).Value & "2"
End If
Next rngCell
End Sub
Related
This question already has answers here:
Return background color of selected cell
(5 answers)
Closed 4 years ago.
I'm fairly new to VBA and I've been struggling over this problem for a couple weeks.
Every time a name has passed a training, the corresponding name/training title cell is filled with the date, and the background is filled in yellow RGB(255,255,0). When IN training they are filled with a yellow background and no date. (There are also some that are red or grey for out of date, but I think I have already worked those out.)
The end goal is to have a separate output sheet within the same file. This sheet will only contain the necessary Training Titles at the top, and all of the names under it if they are the blank yellow cells (No date + yellow). Eventually I would like to be able to email this list to certain people, but I think there are enough resources to figure that out myself.
Currently, I have code to find the max/min of the column/rows, and code that deletes all cells containing dates. My plan was to have it scan the remaining cells for any that were yellow, then paste the training titles/names on a new sheet, but I cannot figure out how to that in VBA.
I'm sure there has to be an easier way to do this as it is several hundred columns wide and rows long.
Thanks for any input!
EDIT: This is the code I am currently using. This scans the range of name vs training and clears the cell data if it is any other color than yellow, or if it is yellow with a date.
I attached an image to help explain more clearly. The important cells are the ones that are yellow with no date. From those cells I need to paste the Training Title in Row 1, and the Name of the person in Column A on a new sheet in the way you can see in the picture.
Sub ClearCellMacro()
Dim myLastCell As Range
Dim cell As Range
Application.ScreenUpdating = False
'Find last cell
Set myLastCell = Range("C4").SpecialCells(xlLastCell)
'Make sure last cell is outside of first row and column (or else exit)
If myLastCell.Row = 1 Or myLastCell.Column = 1 Then Exit Sub
'Loop through entire range removing cell contents if value is not numeric
For Each cell In Range("C4:" & myLastCell.Address)
If Not IsNumeric(cell) Then cell.Clear
Next cell
For Each cell In Range("C4:" & myLastCell.Address)
If cell.Interior.Color <> RGB(255, 255, 0) Then cell.Clear
Next cell
Application.ScreenUpdating = True
MsgBox "Non-Yellow + Blank Cells Removed."
End Sub
This will not clear the non-numeric cells. I am assuming that is already done.
Any cell that is blank and highlighted yellow will be moved to a table on Sheet2 with corresponding name.
You need to update the 3rd and 4th line of code to reflect your actual sheet names (make sure to leave the quotes of course). Sheet1 reflects your "starting sheet" in photo and Sheet2 reflects your desired output.
This is dynamic by rows and columns. Last row (lRow) is determined by Column A and last column (lCol) is determined by Row 1. Photo of the starting point and output produced by the below macro.
Option Explicit
Sub TestMe()
Dim ws1 As Worksheet: Set ws1 = ThisWorkbook.Sheets("Sheet1")
Dim ws2 As Worksheet: Set ws2 = ThisWorkbook.Sheets("Sheet2")
Dim lCol As Long: lCol = ws1.Cells(1, ws1.Columns.Count).End(xlToLeft).Column
Dim lRow As Long: lRow = ws1.Range("A" & ws1.Rows.Count).End(xlUp).Row
Dim myRange As Range, myCell As Range, myUnion As Range
Dim i as Long
For i = 3 To lCol 'Open column loop
Set myRange = ws1.Range(ws1.Cells(4, i), ws1.Cells(lRow, i))
For Each myCell In myRange 'Open row loop
If myCell = "" And myCell.Interior.Color = 65535 Then
If myUnion Is Nothing Then
Set myUnion = myCell.Offset(0, -i + 1)
Else
Set myUnion = Union(myUnion, myCell.Offset(0, -i + 1))
End If
End If
Next myCell 'Next Row
If Not myUnion Is Nothing Then 'This will need some updating to dynamically paste in first available column
ws2.Cells(1, i - 2).Value = ws1.Cells(1, i).Value
myUnion.Copy
ws2.Cells(2, i - 2).PasteSpecial xlPasteValues
Set myUnion = Nothing
End If
Next i 'Next Column
End Sub
I am trying to fill down two before (A, and B) to the last row in column c.
however, My code only insert the formula and doesn't fill down. if I continue to execute the code it will fill one line. then if I click execute again it will fill another line.
Sub row()
Cells(Rows.Count, 1).End(xlUp).Offset(1, 1).Select
ActiveCell.Formula = "=year(today())" 'this will be inserted into the first empty cell in column B
ActiveCell.Offset(0, -1).Value = "Actual" ''this will be inserted into the first empty cell in column A
ActiveCell.FillDown
end sub
Perhaps you mean this? You need to read up on Filldown as you are not specifying a destination range.
Sub row()
With Range(Cells(1, 3), Cells(Rows.Count, 3).End(xlUp))
.Offset(, -1).Formula = "=year(today())"
.Offset(, -2).Value = "Actual"
End With
End Sub
First, take Mat's Mug's suggestion from the comments and make sure you qualify which sheet/workbook you are calling the Cells method on. Then, try the code below. I believe FillDown will only work if there is something in the cells below to replace. Otherwise the function wouldn't know where to stop if it is filling empty cells. Instead, find the last used cell in column C and then blast the value/functions you want in all of the cells in rows A and B at once.
Sub row()
Dim wb As Workbook
Dim ws as Worksheet
Dim rngA As Range
Dim rngB As Range
Dim rngC As Range
Set wb = ThisWorkbook
Set ws = wb.Worksheets("SheetNameHere") ' change this to an actual sheet name
Set rngA = ws.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
Set rngB = rngA.Offset(0,1)
Set rngC = ws.Cells(Rows.Count, 3).End(xlUp)
ws.Range(rngA,rngC.Offset(-2,0)).Value = "Actual" ''this will be inserted into ever empty cell in column A up to the last cell in Column C
ws.Range(rngB,rngC.Offset(-1,0)).Formula = "=year(today())" 'this will be inserted into every empty cell in column B up to the last cell in Column C
End Sub
I am trying to change the background colour of certain cells in sheet 1 based on the same set of values in the sheet 2.
I want it to search the values in sheet 2 to sheet 1, if the values are same then the colour should change according to whatever color code we give. Below are screenshots of sheet1 (green) where I want to apply formatting and other is sheet2 is where I give input
I have got this code below, but it is selecting the cells in which data is not available also, please explain.
Option Explicit
Public Sub tmpSO()
Dim cell As Range
For Each cell In Sheet1.Range("A1:B10")
If cell.Value2 <> Sheet2.Cells(cell.Row, cell.Column).Value2 Then
cell.Interior.Color = vbRed
End If
Next cell
End Sub
#Peh , please check the below screenshot for how exactly my out put should look like in sheet1 based on the values in sheet2.
Output (Sheet1)
Input (Sheet2)
Your code is working fine. In sheet 1 it colors every cell of Range("A1:B10") that is different from sheet 2. If you don't want empty cells of sheet 1 to be colored you need to check for empty cells too.
Option Explicit
Public Sub tmpSO()
Dim cell As Range
For Each cell In Sheet1.Range("A1:B10")
If cell.Value2 <> Sheet2.Cells(cell.Row, cell.Column).Value2 And _
cell.Value2 <> vbNullString Then
cell.Interior.Color = vbRed
End If
Next cell
End Sub
Update for the updated question:
Therefore you will need a second loop. The first loop loops through the cells you want to format, the second loop loops through the input values and compares them to every cell of the first loop.
Option Explicit
Public Sub tmpSO()
Dim iCell As Range, jCell As Range
Dim FormatRange As Range
Set FormatRange = Sheet1.Range("A1:H11") 'the range you want to format
Dim InputRange As Range
Set InputRange = Sheet2.Range("B4:B10") 'the range where your input values are
For Each iCell In FormatRange
For Each jCell In InputRange
If iCell.Value2 = Sheet2.Cells(jCell.Row, jCell.Column).Value2 And _
iCell.Value2 <> vbNullString Then 'compare cell with all input values but left out empty cells
iCell.Interior.Color = vbRed
Exit For ' we can abort compairing with other input values if one is found.
End If
Next jCell
Next iCell
End Sub
I'm making a simple subtraction between two cells that contain dates in order to obtain the period. Every client, in Data_p worksheet, Range ("4"), will have all the order dates in the respective column. So the subtraction will be between the second date and the first, and so on, and the result will be pasted in Data_p_mgnt. This function will have to be executed until there're no more dates for each client.
I have the following code, but I don't know why it won't stop when it finds and Empty cell in Data_p. Any insight will be appreciated.
Sub Prueba_Data_p_mgnt()
Sheets("Data_p_mgnt").Select
Range("B5").Select 'Starts in cell B5
Do Until IsEmpty(Worksheets("Data_p").Range("B5")) 'Checks if cells in Data_p are Empty or Blank
ActiveCell.FormulaR1C1 = "=Data_p!R[1]C-Data_p!RC" 'Makes the subtraction between cells
ActiveCell.Offset(1, 0).Range("A1").Select 'Moves down for paste the next period
Loop 'Loop until there's an Empty cell in Data_p
'Then should move to next client to the right and repeat until there are no more clients in row 4
End Sub
I believe this is what you are trying to do:
Sub Prueba_Data_p_mgnt()
Dim wsMgnt As Worksheet
Dim wsData As Worksheet
Dim rowNo As Long
Dim colNo As Long
Set wsMgnt = Worksheets("Data_p_mgnt")
Set wsData = Worksheets("Data_p")
colNo = 2
Do Until IsEmpty(wsData.Cells(4, colNo)) 'Checks if cells in Data_p are Empty or Blank
rowNo = 5
Do Until IsEmpty(wsData.Cells(rowNo, colNo)) 'Checks if cells in Data_p are Empty or Blank
'Alternatively, to avoid subtracting the last non-blank cell from a blank cell
'Do Until IsEmpty(wsData.Cells(rowNo + 1, colNo)) 'Checks if cells in Data_p are Empty or Blank
wsMgnt.Cells(rowNo, colNo).FormulaR1C1 = "=Data_p!R[1]C-Data_p!RC" 'Makes the subtraction between cells
'Alternatively, if you would rather have values than formulae
'wsMgnt.Cells(rowNo, colNo).Value = wsData.Cells(rowNo + 1, colNo).Value - wsData.Cells(rowNo, colNo).Value
rowNo = rowNo + 1 'Moves down for paste the next period
Loop 'Loop until there's an Empty cell in Data_p
colNo = colNo + 1 'Then should move to next client to the right and repeat until there are no more clients in row 4
Loop
End Sub
This should, I hope, do the trick:
Sub Prueba_Data_p_mgnt()
Dim dataWS As Worksheet
Dim rng As Range
Set dataWS = Sheets("Data_p_mgnt")
Set rng = dataWS.Range("B5") ' what's this? You never use data_p_mgnt cell B5?
For i = 5 To 100 ' Change 100 to whatever you need
If Not IsEmpty(Worksheets("Data_p").Range("b" & i)) Then 'Checks if cells in Data_p are Empty or Blank
Worksheets("Data_p").Range("b" & i).FormulaR1C1 = "=Data_p!R[1]C-Data_p!RC" 'Makes the subtraction between cells
End If 'Loop until there's an Empty cell in Data_p
Next i
End Sub
But looking at your code, I don't know what you plan on doing with B5 on the Data_p_mgnt sheet.
I am trying to paste a formula next to range of cells, but only the one's that contains a value, the script must loop until the next cell in the range is empty. For instance Sheet 1 Column A contains date until row 12, then I would like to paste a formula in column D2:D12 Regards
Like this?
Option Explicit
Sub Sample()
Dim lastRow As Long, i As Long
Dim ws As Worksheet
Set ws = Sheets("Sheet1")
lastRow = ws.Range("A" & Rows.Count).End(xlUp).Row
With ws
For i = 1 To lastRow
If Len(Trim(.Range("A" & i).Value)) <> 0 Then _
.Range("D" & i).Formula = "YOUR FORMULA"
Next i
End With
End Sub
As you are looking down to the first blank cell then you can avoid a loop and use
The code includes a test to make sure that the code doesn't proceed if all of column A is blank - ie if the range from A1 down extends to the bottom of the sheet and A1 is blank
This code adds a sample formula linking each cell in column D to the respective row in column B
Sub FillData()
Dim rng1 As Range
Set rng1 = Range([a1], [a1].End(xlDown))
If Not (rng1.Rows.Count = Rows.Count And Len([a1].Value) = 0) Then rng1.Offset(0, 3).FormulaR1C1 = "=RC2"
End Sub
I like Sid's beginning, but once you have the range of rows, you can insert the formula into column D all at once, without looping, several ways, here's one:
Option Explicit
Sub AddFormula()
Dim LR As Long
LR = Range("A" & Row.Count).End(xlUp).Row
Range("D2:D12").Formula = "=A2 + 7" 'just an example of a formula
End Sub
Try this:
Range("A:A").SpecialCells(2).Areas(1).Offset(, 3).Formula = "MyFormula"
This is a simple solution that is built into Excel, as long as you don't want to copy to the first blank, jump over the blank, then continue copying:
Enter the formula in the first cell of your range, and as long as it is in the column directly to the right or left of your range of filled cells, simply double-click the black box handler in the bottom right-hand corner of the cell. That will automatically copy your formula down to the last non-empty cell of the range.