I have a workbook like so:
Dates
01/02/2017
01/03/2017
BLANK
01/02/2017
I am trying to run a macro but only if all cells in my range are valid dates and not empty.
I am using the below:
Dim cell As Range
'With my workbook, lets check the data
With wb.Worksheets(1)
Lastrow = .Cells(.Rows.count, "G").End(xlUp).Row
'Data Check: Are all dates valid?
For Each cell In Range("E9:E" & Lastrow)
If IsDate(cell.Value) And Not IsEmpty(cell.Value) Then
Continue
Else
Exit Sub
End If
Next
End With
But this is not working. The macro still runs no matter what! If it matters my cells in this column Are data validation lists.
Please can someone show me where i am going wrong?
Reverse the logic a bit:
Dim cell As Range
'With my workbook, lets check the data
With wb.Worksheets(1)
Lastrow = .Cells(.Rows.Count, "G").End(xlUp).Row
'Data Check: Are all dates valid?
For Each cell In Range("E9:E" & Lastrow)
If Not IsDate(cell.Value) Or Trim(cell.Value) = "" Then
Exit Sub
End If
Next
' the rest of your code.
' it will not get here if there are any blanks in or non dates in the range.
End With
Related
I'm having an Excel Spreadsheet with 3 sheets inside and I need to copy certain cell range from Sheet1 and copy it to Sheet2.
And I'm trying to get the range of cells to be copied as an input in a cell that is available in Sheet 3. Like the cell would have value A4:X6 in it. But I'm unable to get the input values passed on to the Range function in my Macro code.
Below is my code and when I execute, it just enters an empty row in the Sheet 2
Sub CopyData()
Sheet3.Select
Set Range1 = Range(Cells(3, 3).Value)
Sheet1.Select
Range1.Copy
Sheet2.Select
Range("A2").Select
Range("A2").EntireRow.Insert Shift:=xlShiftDown
End Sub
I want the contents of cell denoted in Range1 to be copied from Sheet1 and pasted in Sheet2.
Thank you in advance!
John Coleman is right you can avoid using Select for the whole subroutine. But, your problem here is when you define the range it is defining it specifically for Sheet3 and not Sheet1. One alternative is you could store the address in a string that gets passed to the Range() function, but specify which sheet you want your range to reflect. The rest of the code can be handled much the same without using Select.
Sub CopyData()
Dim range1 as Range
dim strRange as String
strRange = Sheet3.Cells(3, 3).Value
Set range1 = Sheet1.Range(strRange)
range1.Copy Sheet2.Range("A2")
Sheet2.Range("A2").EntireRow.Insert Shift:=xlShiftDown
End Sub
Use Set Range1 = Sheet3.Range(Cells(3, 3).Value) instead of Set Range1 = Range(Cells(3, 3).Value) or the range get selected from sheet1 because of Sheet1.Select
when i execute, it just enters an empty row in the Sheet 2 Of course it does. Your code does exactly that. Line Range("A2").EntireRow.Insert Shift:=xlShiftDown creates the row. There is nothing in your code that pastes the content of range A4:X6 ot whatever input you got in the cell.
Actually, if you delete your code and leave it like this:
Sub CopyData()
Range("A2").EntireRow.Insert Shift:=xlShiftDown
End Sub
You will get the same, a new row inserted.
I want the contents of cell denoted in Range1 to be copied from Sheet1 and pasted in Sheet2
I guess you are trying to copy a specific range, not a whole row and paste it, you need something like this:
Sub CopyData()
Dim Range1 As Range
Set Range1 = Sheet1.Range(Sheet3.Cells(3, 3).Value)
Range1.Copy
Sheet2.Range("A2").PasteSpecial (xlPasteAll) 'this command will paste the contents
End Sub
This example shows how to insert a line above line 2, copied to the format of the line down (line 3) and from the header line
Range("2:2").Insert CopyOrigin:=xlFormatFromRightOrBelow
As you understood, .Insert will always insert blank row.
I guess that you would like to paste a range in your sheet and not insert a new row for this you should do like this :
Sheets("SheetName").Range("A2").PasteSpecial (xlPasteAll)
Also note that xlPasteAll is an XlPasteType as xlPasteFormats , xlPasteValues and so on.
xlPasteAll will paste all
xlPasteFormats will paste the source format
xlPasteValues will paste the value
So your code would be as below :
Sub CopyData()
Dim Range1 As Range
Dim Range2 As Range
Set Range1 = Sheet1.Range(Sheet3.Cells(3, 3).Value)'Will define the range you want to copy
Range1.Copy 'here you copy the range
Set Range2 = Sheet2.Range("A2") 'Set the range where you want to paste data
Range2.PasteSpecial (xlPasteValues) 'then you will paste your range
End Sub
Click here to get the list of those XlPasteType
BONUS
Sheet2.Select
Range("A2").Select
is the same as
Set Range2 = Sheet2.Range("A2")
But the last way is better because it avoid Select which can slow down your performances !
Is there a specific requirement for inserting the copied data at the top or would you be happy adding it to the end of the "list" instead? If so, you could find the last used row and add it at the bottom instead like this:
Sub CopyFromSheet1toSheet2()
Dim thisBook As Workbook: Set thisBook = ThisWorkbook
Dim sheetOne As Worksheet: Set sheetOne = thisBook.Worksheets("Sheet1")
Dim sheetTwo As Worksheet: Set sheetTwo = thisBook.Worksheets("Sheet2")
Dim copyFromRange As Range: Set copyFromRange = sheetOne.Range("A4:X6")
Dim lastRow As Long: lastRow = sheetTwo.Cells(Rows.Count, 1).End(xlUp).Row
Dim pasteToRange As Range: Set pasteToRange = sheetTwo.Range("A" & lastRow)
copyFromRange.Copy Destination:=pasteToRange
End Sub
"lastRow" returns the numeric value of the last used row in a given column. If you have data in A1:A4 then this code would add the next lot of data copied to A5 and below.
I'm filtering on a helper cell to locate cells in column B that need the contents cleared. Once I filter on the helper cell that has identified cells in column B that need contents cleared, I am having issues clearing the contents in that cell.
I got the general idea down except I cannot figure out how to clear the visible cells only starting from the first visible cell down to the last visible cell. My issue is identifying where is the start of the first visible cell after the filter is applied and where is the last visible cell.
Sub Macro1()
'
' Macro1 Macro
Dim wb As Workbook
Dim ws As Worksheet
Dim FoundCell1 As Range
Set wb = ActiveWorkbook
Set ws = ActiveSheet
'This identifying the row of the last cell to filter on
Const WHAT_TO_FIND1 As String = "Tango"
Set FoundCell1 = ws.Range("AX:AX").Find(What:=WHAT_TO_FIND1)
'This is filtering on the helper cell to determine what cells need to be cleared.
ws.Range("$BA$8:$BA$" & FoundCell1.Row).AutoFilter Field:=1, Criteria1:= _
"Delete"
'This is where I'm having issues. I would like to replace B2 with a more dynamic code
'that finds the first visible cell after the filter is applied and start there.
'I think the xlUp solves the issue of finding the last visible cell but I am not sure
'if that is the best or correct method.
ws.Range("B2:B" & Rows.Count).End(xlUp).SpecialCells(xlCellTypeVisible).ClearContents
End Sub
Here's how I'd do it:
Sub tgr()
Dim wb As Workbook
Dim ws As Worksheet
Dim FoundCell1 As Range
Set wb = ActiveWorkbook
Set ws = wb.ActiveSheet
'This identifying the row of the last cell to filter on
Const WHAT_TO_FIND1 As String = "Tango"
Set FoundCell1 = ws.Range("AX:AX").Find(What:=WHAT_TO_FIND1)
If FoundCell1 Is Nothing Then Exit Sub 'WHAT_TO_FIND1 not found
'This is filtering on the helper cell to determine what cells need to be cleared.
With ws.Range("$BA$8:$BA$" & FoundCell1.Row)
If .Row < 8 Or .Rows.Count = 1 Then Exit Sub 'No data
.AutoFilter Field:=1, Criteria1:="Delete"
On Error Resume Next 'Suppress error in case there are no visible cells
Intersect(.Worksheet.Columns("B"), .Offset(1).Resize(.Rows.Count - 1).EntireRow).SpecialCells(xlCellTypeVisible).ClearContents
On Error GoTo 0 'Remove "On Error Resume Next" condition
.AutoFilter
End With
End Sub
I'm trying to run some VBA that will count how many rows there are which are not empty in a given range, and then paste a formula in column 13 (M) the number of rows down which were not empty.
This is the code I have:
Sub CountCells()
MsgBox WorksheetFunction.CountA(Sheets("DATA").Range("A7:A750"))
Worksheets("DATA").Range("M7:M500").Formula = "=MYFORMULAR"
End Sub
This code currently counts the number of cells which are not empty in column A but then how do I take this number and use it for the next equation?
If there were 200 columns in range A7:A750 with content in, I would like to paste my formular from M7 to M207.
Option Explicit
Sub CountCells()
Dim ws As Worksheet: Set ws = ThisWorkbook.Sheets("DATA")
Dim LRow As Long
'Determine last row
LRow = ws.Range("A" & ws.Rows.Count).End(xlUp).Row
'Apply formula from rows 7 to last row
ws.Range("M7:M" & LRow).Formula = "=MYFORULAR"
End Sub
I am very new to VBA in excel and I have recorded and modified a macro that gets a value then based on an "IF" statement it uses the answer to calculate a value in a certain cell . I need to repeat this until there is a blank cell in column A.
My Data is
Part Number reported actual waste in the first 4 columns here follows my code that I need to repeat until column A is blank.
Sub MissingMix()
'
' MissingMix Macro
' Calculates Missing Mix based on scrap
'
' Keyboard Shortcut: Ctrl+q
Application.Goto Reference:="R1C1"
Application.Goto Reference:="R3C8"
ActiveCell.FormulaR1C1 = "=IF(RC[-5]-RC[-6]>0,SUM(RC[-5]-RC[-6])*RC[+1],"""")"
Application.Goto Reference:="R3C9"
ActiveCell.FormulaR1C1 = "=VLOOKUP(RC[-8],'QAD Weights'!RC[-8]:R[37]C[-5],4)"
End Sub
use this:
' get active sheet
Dim CurrentSheet As Worksheet
Set CurrentSheet = ActiveWorkbook.ActiveSheet
' defining starting row
Dim Values As Range
Set Values = Rows(5)
For i = 2 To Values.Cells.Count - 1
If Values.Cells(i).Text <> "" Then
' Do Something ...
End If
Next
you can also do the check with If Not IsEmpty(Cells(i).Value) Then ...
EDIT
There is another way that you can handle this.
Dim CurrentSheet As Worksheet
Set CurrentSheet = ActiveWorkbook.ActiveSheet
' getting the lastrow by jumping to the last filled row of cell(1,1)
' cell(1,1) means the cell at row=1 and column=1 (column "A")
Dim LastRow As Long
LastRow = CurrentSheet.Cells(1, 1).End(xlDown).Row
MsgBox LastRow
Please see below code I have found on the internet, which is currently working to a certain degree for me.
Could someone possibly commentate on what each line of this code means so I can understand what its doing?
Im trying to understand it with little programming knowledge and add additional code to look for additional values to paste into additional sheets.
I'm also trying to work out how to make them paste to certain rows one after the other and not maintain the row they were originally in on sheet 1.
Code:
Sub Test()
Dim rw As Long, Cell As Range
For Each Cell In Sheets(1).Range("H:H")
rw = Cell.Row
If Cell.Value = "Dept 1" Then
Cell.EntireRow.Copy
Sheets("Sheet2").Range("A" & rw).PasteSpecial xlPasteValues
End If
Next
End Sub
--
Many thanks
I've added comments as requested. To paste them onto the same row, look at removing the rw variable and replacing it with something that increments by one each time
Sub Test()
'declare variables
Dim rw As Long, Cell As Range
'loop through each cell the whole of column H in the first worksheet in the active workbook
For Each Cell In Sheets(1).Range("H:H")
'set rw variable equal to the row number of the Cell variable, which changes with each iteration of the For loop above
rw = Cell.Row
'check if the value of Cell variable equals Dept 1
If Cell.Value = "Dept 1" Then
'copy the entire row if above is true
Cell.EntireRow.Copy
'paste to the same row of Sheet 2
Sheets("Sheet2").Range("A" & rw).PasteSpecial xlPasteValues
End If
Next
End Sub
Here is your Code Commented hope you understand:
Sub Test()
' Variables Defined as follows:
Dim rw As Long, Cell As Range
' Loop Searching each Cell of (Range H1 to end of last H on sheet1
For Each Cell In Sheets(1).Range("H:H")
' now determine current row number:
rw = Cell.Row
' Test cell value if it contain >> Dept 1 as value:
If Cell.Value = "Dept 1" Then
' Select that row and copy it:
Cell.EntireRow.Copy
' now paste the values of that row into A column and rw row on sheet2:
Sheets("Sheet2").Range("A" & rw).PasteSpecial xlPasteValues
' You should add following to:
' Disable marching ants around copied range:
Application.CutCopyMode = False
End If
Next
End Sub