I am new to macro vba I want the macro to add colour yellow to top row i.e. header row and the last column which is blank. The macro should colour the last column which blanks only till where the corresponding rows have data, not the entire column.
below is my code... I get error "error code 1004 application-defined or object-defined"
Private Sub CommandButton8_Click()
'Hide column A to E and color.
ActiveWorkbook.Worksheets("POL").Range("A1", Cells(1, Columns.Count).End(xlToRight)).SpecialCells(xlCellTypeConstants).Interior.ColorIndex = 6
ActiveWorkbook.Worksheets("POL").Columns("A:E").Hidden = True
Application.Wait (Now + TimeValue("0:00:04"))
ActiveWorkbook.Worksheets("POD").Columns("A:E").Hidden = True
End Sub
Excel screen for reference.
The macro should colour top row header and the last column... The last column is blank so it should colour till only where the corresponding row/columns have data.
You could use your used range to get the last row and last column at same time so long as you don't have extra data in the sheet that isn't included in this "table".
Dim lastcell As Range, rng As Range
With ActiveWorkbook.Worksheets("POL")
Set lastcell = .Cells(UsedRange.Rows.Count, UsedRange.Columns.Count)
Set rng = .Range(.Cells(1, lastcell.Column), .Cells(lastcell.Row, lastcell.Column))
End With
rng.Interior.ColorIndex = 6
Update:
Try this one then which finds the last row using the specific column. I set it to use the column before the last one but you can set it to whichever column has the lastrow in it.
Private Sub CommandButton8_Click()
'Hide column A to E and color.
Dim lastcolumn As Long, lastrow As Long
With ActiveWorkbook.Worksheets("POL")
lastcolumn = .Cells(1, Columns.Count).End(xlToLeft).Column
lastrow = .Cells(Rows.Count, lastcolumn - 1).End(xlUp).Row
'lastrow = .range("A" & rows.Count).end(xlup).row 'Use this one if you want to set a specific column to find the last row.
.Range("A1", .Cells(1, lastcolumn)).Interior.ColorIndex = 6
.Range(.Cells(1, lastcolumn), .Cells(lastrow, lastcolumn)).Interior.ColorIndex = 6
End With
ActiveWorkbook.Worksheets("POL").Columns("A:E").Hidden = True
Application.Wait (Now + TimeValue("0:00:04"))
ActiveWorkbook.Worksheets("POD").Columns("A:E").Hidden = True
End Sub
Related
I have a problem with below code. I would like to filter "OS" (filed 61) then if first cell in 1st column below filters is not empty macro should go to first cell below filters in column "57", check if value in that cell is > 365 if yes it should go to column 62 in the same row and put there "overdue" if no then put there "OK". After that it should go to next row and check the same till the end of the filtered rows.
The problem is with visible only cells. Macro is doing it on all rows even not visible.
It should work only for filtered visible rows. Any suggestions?
Sub Patch_Overdue()
Dim i As Long
Dim LastRow As Long
Sheets("Sheet1").Select
'filter AIX OS
Selection.Autofilter Field:=61, Criteria1:="AIX*"
ActiveSheet.Autofilter.Range.Offset(1).SpecialCells(xlCellTypeVisible).Cells(1, 61).Select
If IsEmpty(Selection) = False Then
LastRow = Range("a7").End(xlDown).Row
For i = 1 To LastRow
If ActiveSheet.Autofilter.Range.Offset(1).SpecialCells(xlCellTypeVisible).Cells(i, 57).Value > 365 Then
ActiveSheet.Autofilter.Range.Offset(1).SpecialCells(xlCellTypeVisible).Cells(i, 62).Select
ActiveCell.FormulaR1C1 = "Overdue"
Else
ActiveSheet.Autofilter.Range.Offset(1).SpecialCells(xlCellTypeVisible).Cells(i, 62).Select
ActiveCell.FormulaR1C1 = "OK"
End If
Next i
Else
ActiveSheet.ShowAllData
End If
End Sub
Please, try the next code. It is not tested, but it should work. Basically, it set the range to be processed based on the last cell in A:A and UserRange number of columns, extract the visible cells range, iterate between its areas and the between each area rows and check what you need:
Sub Patch_Overdue()
Dim sh As Worksheet, rngUR As Range, rngVis As Range, i As Long, LastRow As Long
Set sh = Sheets("Sheet1")
If sh.AutoFilterMode Then sh.AutoFilterMode = False 'eliminate a previous filter to correctly calculate last row
LastRow = sh.Range("A" & sh.rows.count).End(xlUp).row 'last row
'filter AIX OS
Set rngUR = sh.Range("A7", sh.cells(LastRow, sh.UsedRange.Columns.count)) 'set the range to be filtered
rngUR.AutoFilter field:=61, Criteria1:="AIX*" 'filter the range according to criteria
Set rngVis = rngUR.Offset(1).SpecialCells(xlCellTypeVisible) 'set the visible cells range
Dim arRng As Range, r As Range
For Each arRng In rngVis.Areas 'iterate between the range areas:
For Each r In arRng.rows 'iterate between the area rows:
If WorksheetFunction.CountA(r) > 0 Then 'for the case of the last row which is empty because of Offset
If r.cells(1, 57).value > 356 Then
r.cells(1, 62).value = "Overdue"
Else
r.cells(1, 62).value = "OK"
End If
End If
Next
Next
sh.ShowAllData
End Sub
Two questions:
1) I have a spreadsheet (TC) that has data on one page that will be updated daily. There are 28 columns. Essentially I am looking to have the line (row) data cut and paste into a second spreadsheet (Archive) when Col. 28 has a value entered in it. I have the base coding but for some reason it causes Excel to be non-responsive.
I think it might be because the coding goes cell by cell rather than row by row. Can anyone point me in the right direction? (Again, keep in mind, this is a snippet of the coding - I have each Cut and Paste up to Column 28.)
2) The second part of my question is: Will what I have written make sure that when the Command Button is pressed next time, the data will cut and paste to the next blank line. Thank you!
Private Sub CommandButton1_Click()
a = Worksheets("TC").Cells(Rows.Count, 2).End(xlUp).Row
'Dim rng As Range
'Set rng = Worksheets("Archived").Range("A1")
b = 1
For i = 2 To a
If Worksheets(“TC”).Cells(i, 28).Value <> "" Then
'Change # to be the number column of Pt Name
Worksheets(“TC”).Cells(i, 1).Cut
'Change ,# to be the number column of where you want it pasted.
Worksheets(“TC”).Paste Destination:=Worksheets(“Archive”).Cells(b + 1, 1)
'Change ,# to be the number column of SOC
Worksheets(“TC”).Cells(i, 2).Cut
'Change ,# to be the number column of where you want it pasted.
Worksheets(“TC”).Paste Destination:=Worksheets(“Archive”).Cells(b + 1, 2)
b = b + 1
End If
Next
Application.CutCopyMode = False
ThisWorkbook.Worksheets(“TC”).Cells(1, 1).Select
End Sub
You can do something like this:
Private Sub CommandButton1_Click()
Dim i as long, b As Long, shtTC as worksheet, shtArch as worksheet
Set shtTC = Worksheets("TC")
Set shtArch = Worksheets("Archive")
'find the first empty row
b = shtArch.Cells(Rows.Count, 2).End(xlUp).Row + 1 'pick a column which will always be populated
For i = 2 To shtTC.Cells(Rows.Count, 2).End(xlUp).Row
If shtTC.Cells(i, 28).Value <> "" Then
'cut the row
shtTc.Cells(i, 1).Resize(1, 28).Cut shtArch.Cells(b, 1)
b = b + 1
End If
Next
Application.CutCopyMode = False
shtTC.Cells(1, 1).Select
End Sub
Here's an example of how to create the kind of copy results you're looking for. Notice that, unless you specifically want to copy/paste all of the formatting with the data, you don't need to use copy/paste. You can perform the copy by assigning the values of the ranges.
Option Explicit
Private Sub CommandButton1_Click()
CopyData ThisWorkbook.Sheets("TC"), ThisWorkbook.Sheets("Archived")
End Sub
Public Sub CopyData(ByRef source As Worksheet, _
ByRef dest As Worksheet, _
Optional ByVal deleteSource As Boolean = False)
'--- calculate and create the source data range
Const TOTAL_COLUMNS As Long = 1
Dim srcRange As Range
Dim lastRow As Long
With source
lastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
Set srcRange = .Range("A1").Resize(lastRow, TOTAL_COLUMNS)
End With
'--- determine where the data should go
Dim destRange As Range
With dest
lastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
If lastRow > 1 Then lastRow = lastRow + 1
Set destRange = .Cells(lastRow, 1)
Set destRange = destRange.Resize(srcRange.Rows.Count, TOTAL_COLUMNS)
End With
'--- now copy the data
destRange.Value = srcRange.Value
'--- optionally delete the source data
If deleteSource Then
srcRange.Clear
End If
End Sub
I have a workbook with around 75 worksheets, that all contain different sorts of data that get updated every month. Some of the data gets updated automatically, but in nearly every worksheet, there are formulas that need to be dragged. I need to drag the formulas down 30 rows in every worksheet.
So I want to loop through each worksheet and then through each column that contains formulas to drag. I have already marked each column to drag with the letter "F" in row 1 of the column so that I can put an IF statement to only drag those columns.
My problem now is that I do not know how to select the last cell of column with a formula in it and then drag it down 30 rows.
Sub Drag_Formulas()
'Number of Worksheets
Dim i As Integer
Dim ws_num As Integer
ws_num = ThisWorkbook.Worksheets.Count
'Number of columns
Dim c As Integer
'Loop 1
For i = 1 To ws_num
ThisWorkbook.Worksheets(i).Activate
For c = 1 To 105
If Cells(1, c).Value = "F" Then
Cells(20000, c).Select 'I used 20000 since no worksheet has data going as far as 20000, so that way I am sure to get the last cell with data
Selection.End(xlUp).Select
Selection.Copy
Else
Next c
End If
Next c
End Sub
So I got as far as copying the last cell with a formula of a column, but I do not know how to drag it down 30 rows, since with this code I do not know what row the last cell is on.
Thanks for the help!
As mentioned, currently the macro doesn't actually do anything. However, assuming your formula for each column is in row 2, and you want to drag that down to the last row in that column, you could use the following.
Sub drag()
Dim i As Long, col As Long, lastCol As Long, lastRow As Long
Dim copyRowAmt
Dim ws As Worksheet
Dim fmlaCell As Range
copyRowAmt = 30
For Each ws In ThisWorkbook.Worksheets
With ws
' This assumes your column headers are in row 1,
' to get the total number of columns dynamically
lastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
For col = 1 To lastCol
If .Cells(1, col).Value = "F" Then
lastRow = .Cells(.Rows.Count, col).End(xlUp).Row
.Range(.Cells(lastRow, col), .Cells(lastRow + copyRowAmt, col)).Formula = _
.Cells(lastRow, col).Formula
End If
Next col
End With
Next ws
End Sub
Note this also avoids using .Select`.Activate`
I am trying to copy certain cells if the word "FLAG" is a cell in that same row.
For example, I have data in excel like the following:
So if the word Flag is in any of the cells I want to copy the Description, Identifier and Final Maturity columns (Columns A-C) as well as the corresponding date column. So for the first row (AA) under Jan/Feb there is the word Flag. I would want to copy over columns A-E to another worksheet or table.
I would like to use a VBA but I am not sure how
The following code will do what you expect, each time it finds the word FLAG, the first 3 cells will be copied as well as the value for the given month will be copied to a new row, and if a second flag is found that will be copied to the next available row:
Sub foo()
Dim ws As Worksheet: Set ws = Sheets("Sheet1")
Dim wsResult As Worksheet: Set wsResult = Sheets("Sheet2")
'declare and set your worksheet, amend as required
LastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
'get the last row with data on Column A
For i = 2 To LastRow 'loop through rows
For x = 15 To 23 'loop through columns
If ws.Cells(i, x) = "FLAG" Then 'if FLAG found in column
NextFreeRow = wsResult.Cells(wsResult.Rows.Count, "A").End(xlUp).Row + 1 'get the next empty row of your wsResult sheet
ws.Range("A" & i & ":C" & i).Copy 'copy first three cells in given row
wsResult.Range("A" & NextFreeRow).PasteSpecial xlPasteAll 'paste into your Result sheet
ws.Cells(i, x - 11).Copy 'copy the value for which there was a flag
wsResult.Cells(NextFreeRow, 4).PasteSpecial xlPasteAll 'paste in the fourth cell in the sheet wsResult
End If
Next x
Next i
End Sub
I'm at a loss on this and need some help. I've lurked around at answers and have Frankensteined together some code for a macro but it just isn't working.
Here is part of what I have so far:
With ActiveSheet
Firstrow = 1
Lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
For lrow = Lastrow To Firstrow Step -1
With .Cells(lrow, "G")
Range("G1").Select
ActiveCell.FormulaR1C1 = "=IF(ISNUMBER(RC[1]),RC[1],RC[-1])"
End With
Next lrow
End With
I have a very similar block of code before this that deletes crap from the text files I'm importing and it works perfectly through all the number of rows. When I run the same thing with this formula, it only puts the formula in G1 and doesn't cycle through the rest of the sheet. I've tried this and it works, but copies down through all million plus rows:
ActiveCell.FormulaR1C1 = "=IF(ISNUMBER(RC[1]),RC[1],RC[-1])"
Selection.AutoFill Destination:=Range("G:G")
I've tried this and then run the same code that gets rid of the text file crap but I get an error "End If without block If".
To fill the formula in one cell at a time you need to cycle through them; don't keep relying on the ActiveCell property.
With ActiveSheet
Firstrow = 1
Lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
For lrow = Lastrow To Firstrow Step -1
.Cells(lrow, "G").FormulaR1C1 = "=IF(ISNUMBER(RC[1]),RC[1],RC[-1])"
Next lrow
End With
But you can speed things up by putting the formula into all of the cells at once.
With ActiveSheet
Firstrow = 1
Lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
With .Range(.Cells(Firstrow, "G"), .Cells(Lastrow, "G"))
.FormulaR1C1 = "=IF(ISNUMBER(RC[1]),RC[1],RC[-1])"
End With
End With
See How to avoid using Select in Excel VBA macros for more methods on getting away from relying on select and activate to accomplish your goals.
Another version, to dynamically select the columns based on their titles. Comments included.
Dim row As Range
Dim cell As Range
Static value As Integer
'Set row numbers
'Find the starting row. Located using Title of column "Start" plus whatever number of rows.
Dim RowStart As Long
Set FindRow = Range("A:A").Find(What:="Start", LookIn:=xlValues)
RowStart = FindRow.row + 1
'End of the range. Located using a "finished" cell
Dim RowFinish As Long
Set FindRow = Range("A:A").Find(What:="Finished", LookIn:=xlValues)
RowFinish = FindRow.row - 1
'Set range - Goes Cells(Rownumber, Columnnumber)
'Simply ammend RowStart and RowFinish to change which rows you want.
' In your case you need to change the second column number to paste in horizontally.
Set rng = Range(Cells(RowStart, 1), Cells(RowFinish, 1))
'Start the counter from the starting row.
value = RowStart
For Each row In rng.Rows
For Each cell In row.Cells
'Insert relevant formula into each cell in range.
cell.Formula = _
"=IF(ISNUMBER(RC[1]),RC[1],RC[-1])"
'Increment row variable.
value = value + 1
Next cell
Next row