I made this macro (and it works!) but I want to expand on it. Some of the data in the "Data" sheet is irrelevant and I don't want to autofill those rows in the "Databehandling" sheet.
I want to change the LastRow definition. Column G in my data-sheet contains a lot of dates and times (ex. 2016-09-26 09:42:56.290) and the data connected with the last date (2016-09-26) messes with my analysis (a lot of null-values because there's no data as-of-yet). Since I have to update this workbook regularly, I can't just say exclude 2016-09-26. The macro has to look at the date at the very bottom of the data-sheet and move the selection up so those dates aren't included in the selection.
So how can I do that?
Sub Kviklevering_Drag_Down()
On Error GoTo errHandler
Application.ScreenUpdating = False
With ActiveWorkbook
Lastrow = ActiveWorkbook.Sheets("Data").UsedRange.Rows.Count
Sheets("Databehandling").Activate
Range("A2:V2").Select
Selection.AutoFill Destination:=Range("A2:V" & Lastrow), Type:=xlFillDefault
End With
Sheets("Databehandling").Visible = False
Sheets("Data").Activate
Application.ScreenUpdating = True
errHandler:
Application.ScreenUpdating = True
End Sub
I've updated your code. Removed looking at the ActiveBook, activating sheets and moved the error handler outside the main procedure (after the Exit Sub, but before the End Sub).
Sub Kviklevering_Drag_Down()
Dim CountOfMaxDate As Long
Dim rLastCell As Range
Dim rCountRange As Range
Dim dMaxDate As Double
'Are you sure it's always the ActiveWorkbook?
'May be better to use ThisWorkbook which is always the file with this code in,
'or a specific named workbook.
'With ActiveWorkbook
On Error GoTo ErrorHandler
With ThisWorkbook
With Worksheets("Data")
'Find last cell in column G (column 7).
Set rLastCell = .Cells(.Rows.Count, 7).End(xlUp)
If rLastCell.Row = 1 Then
Err.Raise vbObjectError + 1000, , "Last Cell is row 1"
End If
Set rCountRange = .Range(.Cells(1, 7), rLastCell)
'Get the value of the last date.
dMaxDate = Int(rLastCell)
'Count the last date.
CountOfMaxDate = WorksheetFunction.CountIfs(rCountRange, ">=" & dMaxDate, rCountRange, "<" & dMaxDate + 1)
End With
'No need to active this sheet - can leave it hidden if you want.
With Worksheets("Databehandling")
.Range("A2:V2").AutoFill Destination:=.Range("A2:V" & rLastCell.Row - CountOfMaxDate), Type:=xlFillDefault
End With
End With
FastExit:
'Tidy up before exiting procedure.
Exit Sub
On Error GoTo 0
Exit Sub
ErrorHandler:
Select Case Err.Number
Case -2147220504 'Last Cell is row 1
'Handle error.
'Possible things to do after error handled:
'Resume Next
'Resume
'Resume FastExit
Case Else
MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure Kviklevering_Drag_Down."
End Select
End Sub
Related
Sub addRows()
' Adds new blank lines based on user input, keeping formatting and formulas of above.
Dim numRows As Long
Dim raSource As Range
Dim bResult As Boolean
Set raSource = ActiveCell.EntireRow
numRows = InputBox("Enter number of rows to insert. Rows will be added above the highlighted row.")
On Error Resume Next
raSource.Copy
bResult = Range(raSource.Offset(1, 0), raSource.Offset(numRows,
0)).EntireRow.Insert(Shift:=xlShiftDown, CopyOrigin:=xlFormatFromLeftOrAbove)
Application.CutCopyMode = False
If Not bResult Then
MsgBox "Inserting rows failed!", vbExclamation
End If
End Sub
The code works how I want it to except it keeps all the data from the selected row and pastes it to new rows. I want to only keep the formatting and formulas of the selected row and insert the new row below.
Try this code. I have linkedan example workbook as well. Let me know if this works.
Download example workbook here
Sub insertXRows()
Dim cell As Range
Dim lngRows As Long
Application.ScreenUpdating = False
'ERROR HANDLER
On Error GoTo ErrMsg
'#CHECK IF ACTIVE CELL IS IN A TABLE
'SOURCE: https://stackoverflow.com/a/34077874/10807836
Dim r As Range
Dim lo As ListObject
Set r = ActiveCell
Set lo = r.ListObject
If Not lo Is Nothing Then
Select Case lo.Name
Case "Table1"
If r.Row = lo.Range.Row Then
MsgBox "In Table1 Header"
Else
MsgBox "In Table1 Body"
End If
Case "SomeOtherTable"
'...
End Select
Else
MsgBox "Active cell is not in any table. Please select a cell in an active table and retry."
Exit Sub
End If
'MSGBOX to enter #rows to insert
lngRows = InputBox("Enter number of rows to insert. Rows will be added above the highlighted row.")
'CODE TO INSERT X Rows
Selection.Resize(lngRows).EntireRow.Insert
For Each cell In Intersect(ActiveSheet.UsedRange, Selection.Offset(-1, 0).EntireRow)
If cell.HasFormula Then
cell.Copy cell.Offset(1, 0)
End If
Next
Application.ScreenUpdating = True
'ERROR MSG
On Error GoTo 0
Exit Sub
ErrMsg: MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure insertX, line " & Erl & "."
End Sub
My workbook has 4 tabs. I need to move data from all three tabs to a summary sheet. The code works until I add the section to pull from the second sheet. (I haven't bothered trying to pull from the 3rd sheet yet as I can't get this to work). The source range is different for all three sheets and well as the columns to copy.
This code sometimes works and sometimes doesn't. Upon first opening spreadsheet, it will work correctly the first time. Subsequent times, the data from source2 is overwriting the data from source1 starting with row 1, or it adds the data after a few blank rows.
I have tried several variations I have found in forums with the same results.
Sub SendToSummary()
Dim c As Range
Dim j As Integer
Dim k As Integer
Dim lastrow As Long
Dim Source As Worksheet
Dim Source2 As Worksheet
Dim Source3 As Worksheet
Dim Target As Worksheet
' Designations
Set Source = ActiveWorkbook.Worksheets("Pool Cleaners")
Set Source2 = ActiveWorkbook.Worksheets("Service Technicians")
Set Source3 = ActiveWorkbook.Worksheets("PCQC Bonello Commissions")
Set Target = ActiveWorkbook.Worksheets("Summary")
lastrow = Target.Range("a1").End(xlDown).Row + 1
Sheets("Summary").Cells.Clear
Sheets("Summary").Cells.Interior.ColorIndex = xlColorIndexNone
Sheets("Summary").Select
j = 1 ' Start copying to row 1 in target sheet
For Each c In Source.Range("N:N") ' Do column N moving hours to summary sheet
If c > 0 Then
Source.Rows(c.Row).Columns("I:Q").Copy
Target.Rows(j).PasteSpecial Paste:=xlPasteValuesAndNumberFormats
j = j + 1
End If
Next c
Sheets("Summary").Select
With ActiveSheet 'delete blank hours & headers
.AutoFilterMode = False
With Range("f1", Range("F" & Rows.Count).End(xlUp))
.AutoFilter 1, ""
On Error Resume Next
.Offset(1).SpecialCells(12).EntireRow.Delete
.AutoFilter 1, "hours"
On Error Resume Next
.Offset(1).SpecialCells(12).EntireRow.Delete
End With
.AutoFilterMode = False
End With
k = lastrow
For Each c In Source2.Range("Q:Q") 'copying tech commissions over
If c > 0 Then
Source2.Rows(c.Row).Columns("k:s").Copy
Target.Rows(k).PasteSpecial Paste:=xlPasteValuesAndNumberFormats
k = k + 1
End If
Next c
End Sub
Responding to your question in the comments:
Here:
Sheets("Summary").Select
With ActiveSheet 'delete blank hours & headers
.AutoFilterMode = False
With Range("f1", Range("F" & Rows.Count).End(xlUp)) '<<<<< here
.AutoFilter 1, ""
On Error Resume Next
.Offset(1).SpecialCells(12).EntireRow.Delete
.AutoFilter 1, "hours"
On Error Resume Next
.Offset(1).SpecialCells(12).EntireRow.Delete
End With
.AutoFilterMode = False
End With
Your outer With object is Activesheet, so anything in the With block which is preceded by . is linked to that object. The Range calls in the flagged line are not explicitly tied to the With block object (since they have no .) except by "accident" because the With block object in this case is the active sheet, and unqualified Range references in a regular code module default to the ActiveSheet.
Your code "works" as long as "Summary" is active, but will break otherwise.
You could do something like this, and avoid needing to activate the sheet:
With Target 'delete blank hours & headers
.AutoFilterMode = False
With .Range("f1", .Range("F" & Rows.Count).End(xlUp)) '<<<<< here
.AutoFilter 1, ""
On Error Resume Next
.Offset(1).SpecialCells(12).EntireRow.Delete
On Error Goto 0
.AutoFilter 1, "hours"
On Error Resume Next
.Offset(1).SpecialCells(12).EntireRow.Delete
On Error Goto 0
End With
.AutoFilterMode = False
End With
I currently have multiple spreadsheets with a row of dates for each employee.
Within the userform that pops up modified for each employee, there is a place for the date at the top, and they fill out the rest of the information and then submit.
Is there a way to match up the date on the sheet with the one on the userform to populate the column underneath?
Assuming you have a textbox on your form that you type the date into.
This first bit of code is ensuring you have a date in the textbox rather than anything else.
Paste this into a normal module. You can place it in the form, but in a module allows it to be used by any other forms you may have that contain a date.
Public Sub FormatDate(ctrl As Control)
Dim dDate As Date
Dim IsDate As Boolean
On Error GoTo ERR_HANDLE
If Replace(ctrl.Value, " ", "") <> "" Then
On Error Resume Next
dDate = CDate(ctrl.Value)
IsDate = (Err.Number = 0)
On Error GoTo -1
On Error GoTo ERR_HANDLE
If IsDate Then
ctrl.Value = Format(ctrl.Value, "dd-mmm-yyyy")
ctrl.BackColor = RGB(255, 255, 255)
Else
ctrl.BackColor = RGB(255, 0, 0)
End If
End If
EXIT_PROC:
On Error GoTo 0
Exit Sub
ERR_HANDLE:
MsgBox Err.Number & ": " & Err.Description, vbOKOnly, "FormatDate()"
Resume EXIT_PROC
End Sub
Place this on the form as the AfterUpdate event for your textbox:
Private Sub txtDate_AfterUpdate()
On Error GoTo ERR_HANDLE
With Me
FormatDate .txtDate
End With
EXIT_PROC:
On Error GoTo 0
Exit Sub
ERR_HANDLE:
MsgBox Err.Number & ": " & Err.Description, vbOKOnly, "txtDate_AfterUpdate()"
Resume EXIT_PROC
End Sub
Any valid date will be formatted as dd-mmm-yyyy, any invalid date will turn the background of the control red.
Next you need to find the date on row 1 of your sheet. Again this can be kept in a normal module so you can use it outside of the form:
Public Function FindDate(DateValue As Date) As Range
Dim rFound As Range
With Sheet2
Set rFound = .Rows(1).Find(DateValue, .Cells(1, 1), xlValues, xlWhole)
If rFound Is Nothing Then
Set rFound = .Cells(1, .Columns.Count).End(xlToLeft).Offset(, 1)
End If
End With
Set FindDate = rFound
End Function
This will return the cell that the date is in or the last blank cell on row 1 if the date isn't found.
I'm not sure if you want this bit, but this then finds the last cell containing data in a specified column number:
Public Function LastCell(wrksht As Worksheet, Col As Long) As Range
Dim lLastRow As Long
On Error Resume Next
lLastRow = wrksht.Columns(Col).Find("*", , , , xlByColumns, xlPrevious).Row
On Error GoTo 0
If lLastRow = 0 Then lLastRow = 1
Set LastCell = wrksht.Cells(lLastRow, Col)
End Function
Now you just need to attach the code to your find button to return the first blank cell beneath the date you specify:
Private Sub btnFind_Click()
Dim rFoundCell As Range
'First blank cell beneath date.
Set rFoundCell = LastCell(Sheet1, FindDate(CDate(Me.txtDate)).Column).Offset(1)
End Sub
If you just wanted to find the date you can just use:
Set rFoundCell = FindDate(CDate(Me.txtDate))
The help file on Find is here.
Finding dates can be problematic in Excel:
excel-vba-range-find-date-that-is-a-formula
DateTimeVBA
Below code is for retrieving header data from first sheet (starting in cell A1) then copying range from second row.
I would like to modify this to retrieve header date from first sheet: it is the row starting with Cell containing value "Sales organization", then copy the range from all sheet starting from under the header (Cell containing value "Sales organization") into sheet Master.
Can someone please help me to modify it so?
Many thanks!
Sub CopyFromWorksheets()
Dim wrk As Workbook
Dim sht As Worksheet
Dim trg As Worksheet
Dim rng As Range
Dim colCount As Integer
Set wrk = ActiveWorkbook
For Each sht In wrk.Worksheets
If sht.Name = "Master" Then
MsgBox "There is a worksheet called as 'Master'." & vbCrLf & _
"Please remove or rename this worksheet since 'Master' would be" & _
"the name of the result worksheet of this process.", vbOKOnly + vbExclamation, "Error"
Exit Sub
End If
Next sht
Application.ScreenUpdating = False
Set trg = wrk.Worksheets.Add(After:=wrk.Worksheets(wrk.Worksheets.Count))
trg.Name = "Master"
Set sht = wrk.Worksheets(1)
colCount = sht.Cells(1, 255).End(xlToLeft).Column
With trg.Cells(1, 1).Resize(1, colCount)
.Value = sht.Cells(1, 1).Resize(1, colCount).Value
.Font.Bold = True
End With
For Each sht In wrk.Worksheets
If sht.Index = wrk.Worksheets.Count Then
Exit For
End If
Set rng = sht.Range(sht.Cells(2, 1), sht.Cells(65536, 1).End(xlUp).Resize(, colCount))
trg.Cells(65536, 1).End(xlUp).Offset(1).Resize(rng.Rows.Count, rng.Columns.Count).Value = rng.Value
Next sht
trg.Columns.AutoFit
Application.ScreenUpdating = True
End Sub
You can use WorksheetFunction.MATCH to find the column of interest - after that, copying the column should be easy:
theColumn = WorksheetFunction.MATCH("Sales organization", Range("1:1"), 0)
which will find the first column in the first row that has exactly Sales organization in it.
Reference: http://msdn.microsoft.com/en-us/library/office/ff835873.aspx
update if there is a chance that there is no cell with "Sales organization" in it, you might want to trap this - since it would generate an error (as pointed out by D_Bester). Something like this:
theColumn = -1 ' set an "impossible" value
' - it will get overwritten by a successful call to MATCH
On Error Resume Next ' ignore error in the next line and keep going
theColumn = WorksheetFunction.MATCH("Sales organization", Range("1:1"), 0)
On Error GoTo 0 ' turn error handling off again
if theColumn > 0 Then
' do whatever you were planning - you found a match
Else
' do something else, since you didn't find a match...
End If
I'm creating an excel file with column A to H are mandatory cells.
This excel file will be passing around for input.
So, I would like to highlight the empty cells as a reminder.
I have written the following code...
Sub Highlight_Cell()
Dim Rng As Range
For Each Rng In Range("A2:H20")
If Rng.Value = "" Then
Rng.Interior.ColorIndex = 6 ‘yellow
Else
Rng.Interior.ColorIndex = 0 'blank
End If
Next Rng
MsgBox "Please fill in all mandatory fields highlighted in yellow."
End Sub
However, I would like to set the range from A2 to the last row that contains data within column A to H.
Also, display the message box only when empty cell exist.
Could you please advise how should I amend?
Million Thanks!!!
This is a VBA solution that prevents the user from saving until the desired range is filled (acknowledging Gserg's comment that that the last row is one that has at least one cell entered)
In the second portion you can either add your sheet index directly, Set ws = Sheets(x) for position x, or Set ws = Sheets("YourSheet") for a specific sheet name
The code will only highlight truly blank cells within A to H of this sheet till the last entered cell (using SpecialCells as a shortcut). Any such cells will be selected by the code on exit
Put this code in the ThisWorkbook module (so it fires whenever the user tries to close the file)
Private Sub Workbook_BeforeClose(Cancel As Boolean)
bCheck = False
Call CheckCode
If bCheck Then Cancel = True
End Sub
Put this code in a standard module
Public bCheck As Boolean
Sub CheckCode()
Dim ws As Worksheet
Dim rng1 As Range
Dim rng2 As Range
bCheck = False
'works on sheet 1, change as needed
Set ws = Sheets(1)
Set rng1 = ws.Columns("A:H").Find("*", ws.[a1], xlValues, xlWhole, xlByRows)
If rng1 Is Nothing Then
MsgBox "No Cells in columns A:H on " & ws.Name & " file will now close", vbCritical
Exit Sub
End If
Set rng2 = ws.Range(ws.[a1], ws.Cells(rng1.Row, "H"))
On Error Resume Next
Set rng2 = rng2.SpecialCells(xlBlanks)
On Error GoTo 0
If rng2 Is Nothing Then Exit Sub
bCheck = True
rng2.Interior.Color = vbYellow
MsgBox "Please fill in all mandatory fields on " & ws.Name & " highlighted in yellow", vbCritical, "Save Cancelled!"
Application.Goto rng2.Cells(1)
End Sub