Copying active row of Sheet1 to Sheet2 based on cell condition (Column F="Yes") and also prevent duplication.
I tried the following
Private Sub CommandButton1_Click()
Dim CustomerName As String, Customeraddress As String, Customercity As String, Custtel As String, Custzip As String
Worksheets("sheet1").Select
CustomerName = Range("A2")
Customeraddress = Range("B2")
Customercity = Range("C2")
Custtel = Range("D2")
Custzip = Range("E2")
Worksheets("sheet2").Select
Worksheets("Sheet2").Range("B4").Select
If Worksheets("Sheet2").Range("B4").Offset(1, 0) <> "" Then
Worksheets("Sheet2").Range("B4").End(xlDown).Select
End If
ActiveCell.Offset(1, 0).Select
ActiveCell.Value = CustomerName
ActiveCell.Offset(0, 1).Select
ActiveCell.Value = Customeraddress
ActiveCell.Offset(0, 1).Select
ActiveCell.Value = Customercity
ActiveCell.Offset(0, 1).Select
ActiveCell.Value = Custtel
ActiveCell.Offset(0, 1).Select
ActiveCell.Value = Custzip
Worksheets("Sheet1").Select
Worksheets("Sheet1").Range("C4").Select
End Sub
So now I need to know how to check if sheet1 Column F="Yes" for that particluar Customer. Then only copy from Sheet1 to Sheet2. If customer info is already present in Sheet2 then dont duplicate if the user clicks the button on sheet1 active row.
Try this code:
Private Sub CommandButton1_Click()
Dim lastrow As Long
'if value in column F not equal "YES" - do nothing and exit sub
If UCase(Range("F" & ActiveCell.Row).Value) <> "YES" Then Exit Sub
With ThisWorkbook.Worksheets("Sheet2")
lastrow = Application.Max(4, .Cells(.Rows.Count, "B").End(xlUp).Row + 1)
'if CustomerName is already in column B of sheet2 - do nothing and exit sub
If WorksheetFunction.CountIf(.Range("B1:B" & lastrow), _
Range("A" & ActiveCell.Row).Value) > 0 Then Exit Sub
.Range("B" & lastrow).Resize(, 5).Value = _
Range("A" & ActiveCell.Row).Resize(, 5).Value
End With
End Sub
And, please, read this post: How to avoid using Select/Active statements:)
Related
I have three macros that work for my first row. I want to create a loop to make that code run for all the rows until the last row of input.
It prints what is missing when an empty cell is found in columns B, D and E. (I will eventually put the three macros into one to make it more concise.)
This is the code for the first row:
'checking if PayorID is empty
Sub error_field()
Sheets("1099-Misc_Form_Template").Select
Range("A2").Select
If Range("A2").Value = "" Then
ActiveCell.Value = ActiveCell.Value & "PayorID"
End If
End Sub
'checking if TIN is empty
Sub error_field2()
Sheets("1099-Misc_Form_Template").Select
Range("A2").Select
If Range("E2").Value = "" Then
ActiveCell.Value = ActiveCell.Value & ", TIN"
End If
End Sub
'checking if AccountNo is empty
Sub error_field3()
Sheets("1099-Misc_Form_Template").Select
Range("A2").Select
If Range("F2").Value = "" Then
ActiveCell.Value = ActiveCell.Value & ", AccountNo"
End If
End Sub
This is what I tried for a loop:
'repeating for all rows
Sub repeat_all_rows()
Dim sh As Worksheet
Dim rw As Range
Dim RowCount As Integer
RowCount = 0
Set sh = ActiveSheet
For Each rw In sh.Rows
If Range("A2").Value = "" Then
ActiveCell.Value = ActiveCell.Value & "PayorID"
If Range("E2").Value = "" Then
ActiveCell.Value = ActiveCell.Value & ", TIN"
If Range("F2").Value = "" Then
ActiveCell.Value = ActiveCell.Value & ", AccountNo"
Exit For
End If
RowCount = RowCount + 1
Next rw
End Sub
I want code to be performed on all the rows until the last row of data is found.
Something like this should work:
'repeating for all rows
Sub repeat_all_rows()
Dim sh As Worksheet
Dim rw As Range
Dim RowCount As Integer
RowCount = 0
Set sh = ActiveSheet
For Each rw In sh.UsedRange.Rows
FlagMissing rw, "A", "Payor ID"
FlagMissing rw, "E", "TIN"
FlagMissing rw, "F", "AccountNo"
Next rw
End Sub
Sub FlagMissing(rw As Range, col as String, Flag As String)
If Len(Trim(rw.cells(1, col).value)) = 0 Then
With rw.Cells(1)
'add the flag with a comma if there's already content there
.Value = .Value & IIf(.Value="", "", ", ") & Flag
End with
End If
End sub
...though I've not accounted for that Exit For in your posted code.
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'm using a table to pull information from separate work books.currently the table has a set end cell, but I'm pulling into too much information. I want to set the end cell to the last row of the data in column D. I need help modifying the code to set the end cell to a dynamic range.
I've already tried to use lastRow = .Cells(.Rows.Count, col).End(xlUp).Row but I keep getting
compile error
at the preceding .Offset that is invalid or unqualified reference
Sub GetData()
Dim strWhereToCopy As String, strStartCellColName As String
Dim strListSheet As String
Dim strCopySheet As String
strListSheet = "List"
On Error GoTo ErrH
Sheets(strListSheet).Select
Range("B2").Select
'this is the main loop, we will open the files one by one and copy their data into the masterdata sheet
Set currentWB = ActiveWorkbook
Do While ActiveCell.Value <> ""
strFileName = ActiveCell.Offset(0, 1) & ActiveCell.Value
strCopyRange = ActiveCell.Offset(0, 2) & ":" & lastRow =
.Cells(.Rows.Count, col).End(xlUp).Row
strWhereToCopy = ActiveCell.Offset(0, 4).Value
strCopySheet = ActiveCell.Offset(0, 6).Value
strStartCellColName = Mid(ActiveCell.Offset(0, 5), 2, 1)
Application.Workbooks.Open strFileName, UpdateLinks:=False,
ReadOnly:=True
Set dataWB = ActiveWorkbook
Sheets(strCopySheet).Select
Range(strCopyRange).Select
Selection.Copy
currentWB.Activate
Sheets(strWhereToCopy).Select
lastRow = LastRowInOneColumn(strStartCellColName)
Cells(lastRow + 1, 1).Select
Selection.PasteSpecial xlPasteValues, xlPasteSpecialOperationNone
Application.CutCopyMode = False
dataWB.Close False
Sheets(strListSheet).Select
ActiveCell.Offset(1, 0).Select
Loop
Exit Sub
ErrH:
MsgBox "It seems some file was missing. The data copy operation is not
complete."
Exit Sub
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 am trying to offset the active cell until a certain condition is met. What I've written is
Do While ActiveCell.Value <> Worksheets("Unit B").Range("D1").Value
ActiveCell.Offset(0, 1).Select
Loop
Can you please help me correct this ?
Giving my entire code for reference:
Private Sub CommandButton1_Click()
Dim ddsdata As Range
Dim i As Long
i = 1
Worksheets("Unit B").Select
Set ddsdata = Worksheets("Unit B").Range("E3:E35")
Worksheets("Data Sheet").Select
Worksheets("Data Sheet").Range("E1").Select
Do While ActiveCell.Offset(0, i) <> Worksheets("Unit B").Range("D1").Value
i = i + 1
Loop
ActiveCell.Offset(1, i).Select
ActiveCell.Value = ddsdata
Try below code. Avoid using Select / Activate / ActiveCell in your code. Also always refer a cell by sheetname then the cell. eg Sheet1.Range("A1") in a workbook for better results.
Private Sub CommandButton1_Click()
Dim ddsdata As Range
Dim i As Long
i = 1
Thisworkoook.Activate
Set ddsdata = Thisworkoook.Sheets("Unit B").Range("E3:E35")
Do While Worksheets("Data Sheet").Range("E1").Offset(0, i) <> Worksheets("Unit B").Range("D1").Value
i = i + 1
Loop
ActiveCell.Offset(1, i).Select
ActiveCell.Value = ddsdata
End Sub