I collated data to see my colleagues' shifts at work.
Sheet1 holds a table showing Shifts. These shift times are formulated. I am trying to copy and paste shift data as values based on today's date.
For example, if today is 31/12/2020 then copy range C3:F10 and paste as values (i.e. data preceding this date). When the date changes to the next day the range then changes from C3:F10 to C3:G10. This I am going to have continuous (a column for each day of the year)
This is what I have so far. I need some direction.
Private Sub test()
For i = c1 To h1
If Worksheets("Sheet1").Cells(i, 1).Value <= Date Then
Worksheets("Sheet1").Column(i).Copy
ActiveSheet.pastevalues
End If
Next
End Sub
Is this what you are trying? I have commented the code so you should not have a problem understanding it. But if you do then simply ask.
Code:
Option Explicit
Sub Sample()
Dim ws As Worksheet
Dim i As Long
Dim lCol As Long
Dim lRow As Long
Dim rng As Range
'~~> Change this to the relevant sheet
Set ws = Sheet1
With ws
'~~> Find last column which has data in row 1
lCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
'~~> Find last row which has data in Col A
lRow = .Range("A" & .Rows.Count).End(xlUp).Row
'~~> Loop through the dates
For i = 3 To lCol
'~~> Check if the date is less than today's date
If .Cells(1, i).Value2 < Date Then
'~~> identify your range
If rng Is Nothing Then
'~~> Row 3 to last row
Set rng = .Range(.Cells(3, i), .Cells(lRow, i))
Else
'~~> Joining ranges
Set rng = Union(rng, .Range(.Cells(3, i), .Cells(lRow, i)))
End If
Else
Exit For
End If
Next i
'~~> Convert to values in one go
If Not rng Is Nothing Then rng.Value = rng.Value
End With
End Sub
In Action:
I created a sample file to test the above code.
Related
To this:
I would like the set of code to be able to pick up every blank in column C and perform a macro in it. It would have been easy if my sheet has a fixed range, however, my list is constantly increasing in rows... Hence, I would need the macro to be able to run macro on blank cells and skip on those filled cells. The macro should also end upon the last filled cell in the column.
Sub Testing()
Dim Rl As Long ' last row
Dim Tmp As Variant
Dim R As Long ' row counter
With ThisWorkbook.ActiveSheet ' modify to suit
Rl = .Cells(.Rows.Count, "C").End(xlUp).Row
' work on column C
For R = 1 To Rl ' start the loop in row 1
Tmp = .Cells(R, "C").Value
If Len(Tmp) Then
Cells(R, "C").Select
Call AutoFill
End If
Next R
End With
Sub AutoFill()
Application.EnableEvents = False
Dim rng As Range
Set rng = Range(Selection, Selection.End(xlDown))
Set rng = rng.Resize(rng.Rows.Count - 1, rng.Columns.Count)
rng.FillDown
End Sub
Your problem is here: If Len(Tmp) Then and that's just checking if Tmp has any length. So this actually ignores your empty cells by skipping them. Instead you are selecting cells with values in them.
Do not loop all cells in a range. Instead just look at those empty cells of interest. For example:
Sub Testing()
Dim LR As Long, LC as Long
Dim rng As Range
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("Sheet1")
With ws
LR = .Cells(.Rows.Count, "A").End(xlUp).Row
LC = .Cells(LR, .Columns.Count).End(xlToLeft).Column
Set rng = .Range(.Cells(1, 1), .Cells(LR, LC))
If WorksheetFunction.CountBlank(rng) > 0 Then
For Each area In rng.SpecialCells(xlCellTypeBlanks).Areas
area.Offset(-1).Resize(area.Rows.Count + 1).FillDown
Next
End If
End With
End Sub
As you can see I left out .Select and ActiveSheet as that's poor coding and usually not needed at all.
I have an excel sheet with a random amount of columns and rows (amount of columns/rows changes every time, as well as the location of each column) where I need to find a certain column with title "Course Info", and then use the CLEAN function on all rows / cells in that column (except for the title row ofcourse).
I have the code for the clean function:
Set Rng = ShData.Range("AB2:AB" & LastRow)
For Each cell In Rng
cell.Value = Application.WorksheetFunction.Clean(cell.Value)
Next cell
Problem here is that Rng is set to column AB, which isn't always that column. I have also made a LastRow & LastCol code to count the amount of rows and columns, but beyond this I'm stuck.
LastRow = ShData.Range(2, Rows.Count).End(xlUp).Row
LastCol = ShData.Range(1, Cols.Count).End(xlToLeft).Column
Use the WorksheetFunction.Match method to get the column number.
Option Explicit
Sub test()
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("Sheet1")
Dim Col As Double
On Error Resume Next 'next line throws error if "Course Info" was not found
Col = Application.WorksheetFunction.Match("Course Info", ws.Rows(1), 0)
On Error GoTo 0 'always re-activate error reporting
If Col <> 0 Then 'only do it if "Course Info" was found
Dim Cell As Range
For Each Cell In ws.Range(ws.Cells(2, Col), ws.Cells(ws.Rows.Count, Col).End(xlUp))
Cell.Value = Application.WorksheetFunction.Clean(Cell.Value)
Next Cell
End If
End Sub
Here:
Option Explicit
Sub Test()
Dim Rng As Range, Col As Long, cell As Range, LastRow As Long, LastCol As Long
With ShData
LastRow = .Range(.Rows.Count, 2).End(xlUp).Row
LastCol = .Range(1, .Columns.Count).End(xlToLeft).Column
Col = .Rows(1).Find("Course Info").Column 'this is to find the column number
Set Rng = .Range(.Cells(2, Col), .Cells(LastRow, Col))
End With
For Each cell In Rng
cell = Application.WorksheetFunction.Clean(cell)
Next cell
End Sub
I have a sheet containing data. I want to delete the columns based on row value.
My code doesn't stop and when I hit escape, it has deleted all of the column from my starting columns.
I want to check values in row 2 from column D to the last used column (I have about 100 columns now) that if they contain C15, C17 and so on then don't do anything, else, delete the columns.
I only have 40k rows. My range, column and row will expand every week so I want to use VBA to cut down formatting time.
Sub test()
'start
Dim LR1 As Long
Dim i As Long
Set ws = ThisWorkbook.ActiveSheet
With ws
LR1 = .Cells(2, .Columns.Count).End(xlToLeft).Column
Dim arr As Variant
Dim x
arr = Array("C15", "C17", "C19", "C20", "C21", "C22", "C23", "C24", "C25", "C28", "C29", "C30", "C32")
For x = LBound(arr) To UBound(arr)
For i = LR1 To 4 Step -1
If .Cells(2, i).Value = arr(x) Then
Else
.Columns(i).Delete
End If
Next i
Next x
End With
End Sub
Besides all the points made in the comments, the main issue is that your looping logic is off. Your outer loop should be the columns, and the inner loop should be the array. But with Select Case this can be simplified this to just one loop anyway.
Perhaps something like this:
Option Explicit
Sub Test()
Dim ws As Worksheet
Set ws = ThisWorkbook.ActiveSheet
With ws
Dim lastCol As Long, i As Long
Dim rng As Range
lastCol = .Cells(2, .Columns.Count).End(xlToLeft).Column
For i = lastCol To 4 Step -1
Select Case .Cells(2, i).Value
Case "C15", "C17", "C19", "C20", "C21", "C22", "C23", "C24", "C25", "C28", "C29", "C30", "C32"
' keep
Case Else
If rng Is Nothing Then
Set rng = .Columns(i)
Else
Set rng = Union(rng, .Columns(i))
End If
End Select
Next i
If Not rng Is Nothing Then
rng.Delete
End If
End With
End Sub
I have an excel chart with a bunch of data
Every few rows is blank
When there is a blank row I would like to concatenate the cells in column A and last 4 characters of column B from the row below, as long as the cell in column A below does not equal "."
I have the following:
Sub Macro3()
'
' Macro3 Macro
'
'
For Each cell In Columns("A")
If ActiveCell.Value = "" Then ActiveCell.FormulaR1C1 = _
"=IF(R[1]C<>""."",CONCATENATE(R[1]C,RIGHT(R[1]C[1],4)),"""")"
Range("A2").Select
Next cell
End Sub
Why entire Col A?
If you are using the cell object to loop then why use ActiveCell?
My recommendation is to find the last row in Col A and then take that into account in identifying your actual range and then loop through that.
Is this what you are trying?
Sub Sample()
Dim aCell As Range
Dim lRow As Range
Dim ws As Worksheet
'~~> Change this to the relevant sheet name
Set ws = ThisWorkbook.Sheets("Sheet1")
With ws
'~~> Find Last row in col A which has data
lRow = .Range("A" & .Rows.Count).End(xlUp).Row
'~~> Check each cell in the relevant range
For Each aCell In .Range("A1:A" & lRow)
If aCell.Value = "" Then _
aCell.FormulaR1C1 = "=IF(R[1]C<>""."",CONCATENATE(R[1]C,RIGHT(R[1]C[1],4)),"""")"
Next aCell
End With
End Sub
Hi fellow communiteers,
I'm running a macro to delete entire rows that contain a certain value. The code works fine on small data sets but on the current one (~22,000 records) it consistently crashes Excel (2010). The code is below. Short of splitting the data into smaller chunks and running the macro again and again I'm not sure what to do.
Any help appreciated and here's the code:
Sub CleanOcc()
'Row counting
Dim Firstrow As Long
Dim Lastrow As Long
Dim Lrow As Long
Dim Lrow2 As Long
With Sheets("Occ_Prep")
'Cleans the occ_prep sheet ready for upload (Column and value can be changed)
Sheets("Occ_Prep").Activate
'Set the first and last row to loop through
Firstrow = .UsedRange.Cells(1).Row
Lastrow = .UsedRange.Rows(.UsedRange.Rows.Count).Row
'We loop from Lastrow to Firstrow (bottom to top)
For Lrow2 = Lastrow To Firstrow Step -1
'We check the values in the A column in this example
With .Cells(Lrow2, "K")
If Not IsError(.Value) Then
If .Value = "0" Then .EntireRow.Delete
'This will delete each row with the Value "ron"
'in Column A, case sensitive.
End If
End With
Next Lrow2
End With
End Sub
Agree with Siddharth comment autofilter is way to go. This should be a lot quicker.
Option Explicit
Sub delrows()
Dim ws As Worksheet
Dim LR As Long
Dim rng As Range, frng As Range
Application.ScreenUpdating = False
Set ws = Sheets("dataset") '<-- Change this to name of your worksheet
With ws
LR = .Range("A" & Rows.Count).End(xlUp).Row
.AutoFilterMode = False
Set rng = .Range("A1:C" & LR) '<-- Assuming K is the last column
rng.AutoFilter 3, "0" '<-- 11 referes to Column K
Set frng = rng.Offset(1, 0).SpecialCells(xlCellTypeVisible) '<-- Don't delete the header
frng.EntireRow.Delete
.AutoFilterMode = False
End With
Application.ScreenUpdating = True
End Sub
Edit: I just cleaned ~20000 rows (3 columns) of data in ~5 seconds. Obviously it depends how many matches there are too.