I am trying to copy a set of cells based on the active cell when the user hits the macro shortcut key.
For example, they have AI10 (R10C35) selected, I want it to copy the range R10C36:R22C79
Then paste values to R11C36:R23C79.
The end of the range to copy will always be R22C79, and the end of the paste will always be R23C79. The start of the range is the only thing that varies based on the active cell.
If I can get the help to select the range and get it to copy, I can figure out the PasteRange and HolidayRange from there.
I'm sure my If statements could be simplified too, and open to constructive criticism on those as well, but the string to range is my main objective because the rest works as is.
As I currently have this, I get:
Runtime Error 1004
Method 'Range' of object '_Global' failed
Thanks!
Dim CurrentColumn As Integer
Dim CopyRange As String
Dim PasteRange As String
Dim HolidayRange As String
CurrentRow = ActiveCell.Row
CurrentColumn = ActiveCell.Column
If CurrentColumn <> "35" Then MsgBox ("You must select a date in column AI")
If CurrentRow < 9 Then MsgBox ("You must select a date in column AI")
If CurrentRow > 22 Then MsgBox ("You must select a date in column AI")
If CurrentColumn <> "35" Then Exit Sub
If CurrentRow < 9 Then Exit Sub
If CurrentRow > 22 Then Exit Sub
CopyRange = "R" & CurrentRow & "C" & CurrentColumn + "1" & ":R22C79"
PasteRange = "R" & CurrentRow + "1" & "C79" & ":R23C79"
Range(CopyRange).Select
Selection.Copy
Range(PasteRange).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
HolidayRange = "R" & CurrentRow & "C36:R" & CurrentRow & "C79"
Range(HolidayRange).ClearContents
I may not have got this quite right, but should give you an idea of how to approach it.
Also worth reading how to avoid select.
Sub x()
Dim CurrentColumn As Long
currentrow = ActiveCell.Row
CurrentColumn = ActiveCell.Column
If CurrentColumn <> 35 Then MsgBox ("You must select a date in column AI"):exit sub
If currentrow < 9 Then MsgBox ("You must select a date in column AI"):exit sub
If currentrow > 22 Then MsgBox ("You must select a date in column AI"):exit sub
Range(Cells(currentrow + 1, CurrentColumn + 1), Cells(23, 79)).Value = Range(Cells(currentrow, CurrentColumn + 1), Cells(22, 79)).Value
Range(Cells(currentrow, 36), Cells(currentrow, 79)).ClearContents
End Sub
Related
I am currently working on writing a data verification makro. Currently, it runs through one column and throws an error if the wrong data type is entered. The columns are dynamic because there will be new entries.
How do I run this code through several columns not only one?
Sub checken()
Dim i As Integer
Range("D4").Select
Do Until IsEmpty(ActiveCell)
If IsNumeric(ActiveCell) = False Then
MsgBox ("A number has to be entered " & "row " & ActiveCell.Row)
End If
ActiveCell.Offset(1, 0).Select
Loop
End Sub
You can try below sub-
Sub CheckColumns()
Dim rng As Range
Dim lCol As Long, lRow As Long
lCol = Range("D4").End(xlToRight).Column
lRow = Range("D4").End(xlDown).Row
For Each rng In Range("D4", Cells(lRow, lCol))
If IsNumeric(rng) = False Then
MsgBox ("A number has to be entered " & "row " & rng.Row)
End If
Next rng
End Sub
Good Morning,
I have a database of safety data sheets for the benefit of COSHH, i am trying to create a function in which the user can enter a date into "H7" and any entried with dates less than that one will have the entire row transferred into sheet2.
the code i have written is as below
Sub checkdatasheets()
Dim datefrom As Variant
'select first entry
Sheet1.Range("E2").Select
'continue until an empty cell is reached
Do Until ActiveCell.Offset(1, 0).Value = ""
If ActiveCell.Value = "" Then GoTo skipto:
'aquire date parameter
datefrom = Sheet1.Range("H7")
'if revision date is less than the date parameter copy and add to sheet2
If ActiveCell.Value <= datefrom Then
ActiveCell.Rows.EntireRow.Copy
Sheets("Sheet2").Select
NextRow = Cells(Rows.Count, 1).End(xlUp).Row + 1
Cells(NextRow, 1).Select
ActiveSheet.Paste
Sheets("Sheet1").Select
End If
'move onto next cell
ActiveCell.Offset(1, 0).Select
Loop
skipto: MsgBox "Missing Data Sheet"
End Sub
The issue i am having is that this code takes certain rows but lots of rows are missed, even though they are less than the datefrom variable?
Thank you in advance for your help, any feedback on the writing of my code would be appreciated.
You should avoid using select and also reference your sheets better. Something like code below should work better allready:
Sub checkdatasheets2()
For X = 2 To Sheets(1).Cells(Rows.Count, 5).End(xlUp).Row
If Sheets(1).Cells(X, 5).Value < Sheets(1).Cells(7, 8).Value Then
Sheets(1).Rows(X).Copy Destination:=Sheets(2).Range("A" & Sheets(2).Cells(Sheets(2).Rows.Count, 5).End(xlUp).Row + 1)
End If
Next X
End Sub
Import the below code in the change event of the sheet which you will import the date.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim sDate As Date
Dim LastRow1 As Long, LastRow2 As Long, i As Long
If Not Intersect(Target, Range("A1")) Is Nothing Then
If IsDate(Target.Value) Then
sDate = CDate(Target.Value)
LastRow1 = Sheet1.Cells(Sheet1.Rows.Count, "A").End(xlUp).Row
For i = 3 To LastRow1
If CDate(Sheet1.Range("A" & i).Value) < sDate Then
LastRow2 = Sheet2.Cells(Sheet2.Rows.Count, "A").End(xlUp).Row
Sheet1.Rows(i).Copy Sheet2.Rows(LastRow2 + 1)
End If
Next i
Else
MsgBox "Please insert a valid date."
End If
End If
End Sub
Sheet 1 (includes the date)
Sheet 2 (Results)
I have data where I have many column headers. One of the header is "Text" and one other header is "Value Date". I want to combine the values contained in every row between these columns in another column row-wise.
The problem is the number of columns between these two headers is not constant. It changes with every new ledger I export. So I want my code to be dynamic in such a way that it will identify the column of "Text" and then it will identify the column of "Value Date" and combine everything between in another column row-wise.
This is where I have reached with my code but I don't know why it's not working. I have been trying this for last 3 days only to get nowhere. When I run this code, the result which I get is "TextColumnNo:ValueColumnNo".
Sub TextJoin()
Dim TextColumnNo As Range
Dim ValueColumnNo As Range
Range("A1").Select
ActiveCell.EntireRow.Find("Text").Activate
Set TextColumnNo = Range(ActiveCell.Address(False, False))
Range("A1").Select
ActiveCell.EntireRow.Find("Value").Activate
Set ValueColumnNo = Range(ActiveCell.Address(False, False))
ActiveCell.Offset(1, -1).Select
Application.CutCopyMode = False
ActiveCell.Value = Application.WorksheetFunction.TextJoin(" ", True, _
"TextColumnNo:ValueColumnNo")
ActiveCell.Select
Selection.AutoFill Destination:=ActiveCell.Range("A1:A8524")
ActiveCell.Range("A1:A8524").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
End Sub
You would need 2 loops for this. One looping through all rows and one looping through the columns to combine the text for each row.
Note that you need to adjust some things like sheet name and output column here.
Option Explicit
Public Sub TextJoin()
Dim ws As Worksheet
Set ws = Worksheets("Sheet1") 'define a worksheet
'find start
Dim FindStart As Range
Set FindStart = ws.Rows(1).Find("Text")
If FindStart Is Nothing Then
MsgBox "start not found"
Exit Sub
End If
'find end
Dim FindEnd As Range
Set FindEnd = ws.Rows(1).Find("Value Date")
If FindEnd Is Nothing Then
MsgBox "start not found"
Exit Sub
End If
'find last used row in column A
Dim lRow As Long
lRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
Dim iRow As Long
For iRow = 2 To lRow 'loop through all rows (2 to last used row)
Dim CombinedText As String
CombinedText = vbNullString 'initialize/reset variable
Dim iCol As Long 'loop through columns for each row (from start to end column)
For iCol = FindStart.Column To FindEnd.Column
CombinedText = CombinedText & ":" & ws.Cells(iRow, iCol).Text 'combine values
Next iCol
ws.Range("Z" & iRow) = CombinedText 'write values in column Z
Next iRow
End Sub
Sub TextJoin()
Dim ColRefText As Long
Dim ColRefValueDate As Long
Const firstcol = "Text"
Const secondcol = "Value Date"
Dim r As Range
Set r = Rows(1).Cells.Find(firstcol)
If Not r Is Nothing Then
ColRefText = r.Column
Set r = Rows(1).Cells.Find(secondcol)
If Not r Is Nothing Then
ColRefValueDate = r.Column
End If
End If
If ColRefValueDate + ColRefText > 0 Then
With Cells(2, Worksheets(1).Columns.Count).End(xlToLeft).Offset(0, 1)
.Formula = Replace("=" & Cells(2, ColRefText).AddressLocal & "&" & Cells(2, ColRefValueDate).AddressLocal, "$", "")
.Copy Range(.Address, Cells(ActiveSheet.UsedRange.Rows.Count, .Column).Address)
End With
End If
End Sub
I want to fill in all empty cells using values of above cells
state name
IL Mike
Sam
CA Kate
Bill
Leah
Should be as follows
state name
IL Mike
IL Sam
CA Kate
CA Bill
CA Leah
I tried the following
Sub split()
Dim columnValues As Range, i As Long
Set columnValues = Selection.Area
Set i = 1
For i = 1 To columnValues.Rows.Count
If (columnValues(i) = "") Then
columnValues(i) = columnValues(i - 1)
End If
Next
End Sub
I get an error when I set i. How can I modify my code
For those not requiring VBA for this, select ColumnA, Go To Special..., Blanks and:
Equals (=), Up (▲), Ctrl+Enter
should give the same result.
Given you asked for VBA, there is a quicker way than looping (the VBA equivalent of what pnuts posed above, with the additional step of removing the formula at the end):
On Error Resume Next
With Selection.SpecialCells(xlCellTypeBlanks)
.FormulaR1C1 = "=R[-1]C"
.Value = .Value
End With
It is because i should be defined as i=1. There are although a few other problems with the code. I would change it to something like this:
Sub split()
Dim columnValues As Range, i As Long
Set columnValues = Selection
For i = 1 To columnValues.Rows.Count
If columnValues.Cells(i, 1).Value = "" Then
columnValues.Cells(i, 1).Value = columnValues.Cells(i - 1, 1).Value
End If
Next
End Sub
Sub fill_blanks()
Dim i As Long
i = 2 ' i<>1 because your first raw has headings "state " "name"
'Assume state is in your cell A and name is in your cell B
Do Until Range("B" & i) = ""
Range("B" & i).Select
If ActiveCell.FormulaR1C1 <> "" Then
Range("A" & i).Select
If ActiveCell.FormulaR1C1 = "" Then
Range("A" & i - 1).Copy
Range("A" & i).PasteSpecial Paste:=xlPasteValues
Else
i = i + 1
End If
Else
i = i + 1
End If
Loop
End Sub
For some cause the method used on post https://stackoverflow.com/a/20439428/2684623 not work for me. When the line .value=.value is executed, I get the error 'not available' (#N/D for local language) in the value of cells. Version of Office is 365.
I dont know the reason however with some modifications runs fine:
Sub TLD_FillinBlanks()
On Error Resume Next
With ActiveSheet.UsedRange.Columns(1)
If .Rows(1) = "" Then .Rows(1).Value = "'"
.SpecialCells(xlCellTypeBlanks).FormulaR1C1 = "=R[-1]C"
.Value = .Value
End With
End Sub
Using loops:
Sub TLD_FillinBlanksLoop()
Dim rCell As Range
For Each rCell In ActiveSheet.UsedRange.Columns(1).Cells
If rCell.Value = "" And rCell.Row > 1 Then
rCell.FillDown
End If
Next
End Sub
I hope that can be useful for somebody. Thanks and regards.
Here is the whole module, I pasted the formulas as values at the end.
Sub FillBlanksValueAbove()
Dim sName As String
sName = ActiveSheet.Name
Dim ws As Worksheet
Dim lastRow As Long, lastCol As Long
Dim rng As Range
'Set variable ws Active Sheet name
Set ws = Sheets(sName)
With ws
'Get the last row and last column
lastRow = .Range("A" & .Rows.Count).End(xlUp).Row
lastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
'Set the range
Set rng = .Range(.Cells(1, 1), .Cells(lastRow, lastCol))
rng.Select
'Select Blanks
rng.SpecialCells(xlCellTypeBlanks).Select
'Fill Blanks with value above
Selection.FormulaR1C1 = "=R[-1]C"
'Paste Formulas as Values
rng.Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _
xlNone, SkipBlanks:=False, Transpose:=False
End With
End Sub
I want to fill in all empty cells using values of above cells
state name
IL Mike
Sam
CA Kate
Bill
Leah
Should be as follows
state name
IL Mike
IL Sam
CA Kate
CA Bill
CA Leah
I tried the following
Sub split()
Dim columnValues As Range, i As Long
Set columnValues = Selection.Area
Set i = 1
For i = 1 To columnValues.Rows.Count
If (columnValues(i) = "") Then
columnValues(i) = columnValues(i - 1)
End If
Next
End Sub
I get an error when I set i. How can I modify my code
For those not requiring VBA for this, select ColumnA, Go To Special..., Blanks and:
Equals (=), Up (▲), Ctrl+Enter
should give the same result.
Given you asked for VBA, there is a quicker way than looping (the VBA equivalent of what pnuts posed above, with the additional step of removing the formula at the end):
On Error Resume Next
With Selection.SpecialCells(xlCellTypeBlanks)
.FormulaR1C1 = "=R[-1]C"
.Value = .Value
End With
It is because i should be defined as i=1. There are although a few other problems with the code. I would change it to something like this:
Sub split()
Dim columnValues As Range, i As Long
Set columnValues = Selection
For i = 1 To columnValues.Rows.Count
If columnValues.Cells(i, 1).Value = "" Then
columnValues.Cells(i, 1).Value = columnValues.Cells(i - 1, 1).Value
End If
Next
End Sub
Sub fill_blanks()
Dim i As Long
i = 2 ' i<>1 because your first raw has headings "state " "name"
'Assume state is in your cell A and name is in your cell B
Do Until Range("B" & i) = ""
Range("B" & i).Select
If ActiveCell.FormulaR1C1 <> "" Then
Range("A" & i).Select
If ActiveCell.FormulaR1C1 = "" Then
Range("A" & i - 1).Copy
Range("A" & i).PasteSpecial Paste:=xlPasteValues
Else
i = i + 1
End If
Else
i = i + 1
End If
Loop
End Sub
For some cause the method used on post https://stackoverflow.com/a/20439428/2684623 not work for me. When the line .value=.value is executed, I get the error 'not available' (#N/D for local language) in the value of cells. Version of Office is 365.
I dont know the reason however with some modifications runs fine:
Sub TLD_FillinBlanks()
On Error Resume Next
With ActiveSheet.UsedRange.Columns(1)
If .Rows(1) = "" Then .Rows(1).Value = "'"
.SpecialCells(xlCellTypeBlanks).FormulaR1C1 = "=R[-1]C"
.Value = .Value
End With
End Sub
Using loops:
Sub TLD_FillinBlanksLoop()
Dim rCell As Range
For Each rCell In ActiveSheet.UsedRange.Columns(1).Cells
If rCell.Value = "" And rCell.Row > 1 Then
rCell.FillDown
End If
Next
End Sub
I hope that can be useful for somebody. Thanks and regards.
Here is the whole module, I pasted the formulas as values at the end.
Sub FillBlanksValueAbove()
Dim sName As String
sName = ActiveSheet.Name
Dim ws As Worksheet
Dim lastRow As Long, lastCol As Long
Dim rng As Range
'Set variable ws Active Sheet name
Set ws = Sheets(sName)
With ws
'Get the last row and last column
lastRow = .Range("A" & .Rows.Count).End(xlUp).Row
lastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
'Set the range
Set rng = .Range(.Cells(1, 1), .Cells(lastRow, lastCol))
rng.Select
'Select Blanks
rng.SpecialCells(xlCellTypeBlanks).Select
'Fill Blanks with value above
Selection.FormulaR1C1 = "=R[-1]C"
'Paste Formulas as Values
rng.Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _
xlNone, SkipBlanks:=False, Transpose:=False
End With
End Sub