This code was found on one of the threads.
Everything related to code was useful except one
that is after execution of the code the data is
shifted upwards . I want that row i.e A to F should
become blank and data not shifted upwards. Tried to
remove Shift:=xlShiftUp from code but still data is
shifting upwards in the source file (Sheet1).
code is
Private Sub CommandButton1_Click()
Dim Source As Range, Target As Range
With Worksheets("Sheet1")
Set Source = .Range("A3", .Range("A" & .Rows.Count).End(xlUp))
End With
Set Target = Source.Find(What:=DCNameTextBox1.Value, LookIn:=xlValues, LookAt:=xlWhole)
If Not Target Is Nothing Then
'Reference the next enmpty row on Sheet2
With Worksheets("Sheet2")
With .Range("A" & .Rows.Count).End(xlUp).Offset(1)
'.Range("A1:F1") is relative to the row of it's parent range
.Range("A1:F1").Value = Target.Range("A1:F1").Value
.Range("H1:J1").Value = Array(DCDateTextBox.Value, DispoTextBox.Value, ReasonTextBox.Value)
Set Source = .Range("A3", .Range("A" & .Rows.Count).End(xlUp))
End With
End With
Target.Range("A1:F1").Delete Shift:=xlShiftUp
MsgBox "Client has been moved to Discharge list."
Else
MsgBox "Client not found", vbInformation, "No Data"
End If
Range("A3").Select
End Sub
Not sure I understand completely, but if you want to clear the content of A1:F1 do
Target.Range("A1:F1").ClearContents
instead of
Target.Range("A1:F1").Delete Shift:=xlShiftUp
if there is nothing to the rigth of F1, then you can do
Target.Range("A1:F1").Delete Shift:=xlToLeft
Related
I am trying to select the first visible cell directly beneath the header of a filtered column. The code I am getting is as below, but I have to problems with this code. First, the first line of code is using the current active range of the file. It is highly likely that this file will change and this range will not be the same. How can I make it work for any file I would use it on? Second, if I use a totally different file with the same column format, the first visible cell under Column J could be J210. How can I make this work for any array of variables?
Sub Macro16()
'
' Macro16 Macro
'
'
ActiveSheet.Range("$A$1:$R$58418").AutoFilter Field:=12, Criteria1:= _
"Sheets"
Range("J2").Select
ActiveCell.FormulaR1C1 = "=RIGHT(RC[1],3)"
Selection.FillDown
End Sub
Sub FirstVisibleCell()
With Worksheets("You Sheet Name").AutoFilter.Range
Range("A" & .Offset(1, 0).SpecialCells(xlCellTypeVisible)(1).Row).Select
End With
End Sub
Untested but:
Sub Macro16()
With ActiveSheet.Range("A1").CurrentRegion
.AutoFilter field:=12, Criteria1:="Sheets"
If .Columns(1).SpecialCells(xlCellTypeVisible).count > 1 Then
With .Columns(10)
.Resize(.rows.count - 1).offset(1).SpecialCells(xlCellTypeVisible).FormulaR1C1 = "=RIGHT(RC[1],3)"
End With
End If
End With
End Sub
I prefer non-destructive methods of determining whether there are visible cells to work with after a filtering operation. Since you are filling in column J with a formula, there is no guarantee that column J contains any values tat can be counted with the worksheet's SUBTOTAL function (SUBTOTAL does not count rows hidden by a filter) but the formula you are planning to populate into column J references column K so there must be something there.
Sub Macro16()
With ActiveSheet
If .AutoFilterMode Then .AutoFilterMode = False
With .Cells(1, 1).CurrentRegion
.Columns(12).AutoFilter Field:=1, Criteria1:="Sheets"
With .Resize(.Rows.Count - 1, 1).Offset(1, 9)
If CBool(Application.Subtotal(103, .Offset(0, 1))) Then
.SpecialCells(xlCellTypeVisible).FormulaR1C1 = "=RIGHT(RC[1],3)"
End If
End With
.Columns(12).AutoFilter Field:=1
End With
End With
End Sub
Something like this might work...
Sub Macro16()
Dim ARow As Long, JRow As Long, ws1 As Worksheet
ws1 = Sheets("NAME OF SHEET WITH DATA")
ARow = ws1.Range("A" & ws1.Rows.Count).End(xlUp).Row + 1
ws1.Range("$A$1:$R$" & ARow).AutoFilter Field:=12, Criteria1:="Sheets"
JRow = ws1.Range("J" & ws1.Rows.Count).End(xlUp).Row + 1
ws1.Range("J" & JRow).FormulaR1C1 = "=RIGHT(RC[1],3)"
ws1.Range("J" & JRow).FillDown
End Sub
I have written a few lines of code that work like I want them too but I don't know how to repeat it through all rows of my data.
This probably seems like a rather simple thing but since I started VBA just a few days ago I struggle with this line of code
If I continue with ActiveCell.Offset(-1,-4) after my code it's a bug and I don't know how to repeat the code through all rows.
Sub SelectRowsWithNoBlanks()
Range("A2").Select
If ActiveCell.Offset(0, 0).Value <> "" And ActiveCell.Offset(0, 1) <> "" And ActiveCell(0, 1) <> "" And ActiveCell(0, 1) <> "" Then
Range(ActiveCell, Cells(ActiveCell.Row, ActiveCell.Column + 4)).Select
End If
End Sub
#SiddharthRout As I don't have Access to the data yet I can't tell. But I thought extending the code for more columns later on wouldn't be a problem. So in the code I have written now I was checking for the columns A-D but I thought I could easily add the "checking" for more columns if needed – Anna von Blohn 43 secs ago
In that case, here is a sample code.
Logic
As #Pᴇʜ mentioned avoid the use of .Select. Work with the objects.
Find the last row and loop through the rows. To find the last you you may want to see This
One way (which I am using) is to count the number of cells which are filled using Application.WorksheetFunction.CountA. So if it is columns A to D then there should be 4 cells to be filled to consider the "row" as filled. Similarly for Cols A to E, there should be 5 cells to be filled to consider the "row" as filled as so on.
Code
I have commented the code. So if you have a problem understanding it, let me know.
Option Explicit
Sub SelectRowsWithNoBlanks()
Dim ws As Worksheet
Dim lRow As Long, i As Long
Dim myRange As Range, rng As Range
'~~> Change this to the relevant sheet
Set ws = Sheet1
With ws
'~~> Find the last row in Col A
lRow = .Range("A" & .Rows.Count).End(xlUp).Row
'~~> Loop through the rows
For i = 2 To lRow
'~~> Change this as applicable
Set rng = .Range("A" & i & ":D" & i)
'~~> Check if the range is completely filled
If Application.WorksheetFunction.CountA(rng) = rng.Columns.Count Then
'~~> Store the range in a range object
If myRange Is Nothing Then
Set myRange = rng
Else
Set myRange = Union(myRange, rng)
End If
End If
Next i
End With
'If Not myRange Is Nothing Then Debug.Print myRange.Address
'~~> Check if any filled rows were found
If Not myRange Is Nothing Then
With myRange
'
'~~> Do what you want with the range
'
End With
Else
MsgBox "No filled rows were found"
End If
End Sub
I have a list of files:
They share one common format, only have one sheet, but can have multiple rows with data. They are meant to be opened, all cells with data copied, and then pasted to a sheet called Addresses. Like this:
However what I'm getting is this:
Now I have stepped in and noticed that my other data IS being put in the destination, it's just getting overwritten (in what appears to be a random pattern). Here's the code I used:
Option Explicit
Sub AddressListing()
Dim Cell As Range
With Worksheets("ghgh")
For Each Cell In .Range("A1", .Cells(.Rows.Count, "A").End(xlUp)).Cells
If Len(Dir(Cell.Value)) Then
With Workbooks.Open(Cell.Value)
Range("A2:X" & Cells(Rows.Count, "D").End(xlUp).Row).copy _
ThisWorkbook.Worksheets("Addresses").Cells(Rows.Count, "A").End(xlUp).Offset(1)
.Close SaveChanges:=False
End With
Else
MsgBox "File not found: " & Cell.Value
End If
Next Cell
End With
'Call RemoveViaFilter
End Sub
In an effort to combat this and not waste everyone's time, I created a NextRow variable to find the next blank row in the workbook. It still didn't work. I don't get an error message, the data is simply input the same way.
Here's the code with NextRow:
Option Explicit
Sub AddressListing2()
Dim Cell As Range
Dim NextRow As Long
NextRow = ThisWorkbook.Sheets("Addresses").Range("D" & Rows.Count).End(xlUp).Row + 1
With Worksheets("ghgh")
For Each Cell In .Range("A1", .Cells(.Rows.Count, "A").End(xlUp)).Cells
If Len(Dir(Cell.Value)) Then
With Workbooks.Open(Cell.Value)
Range("A2:X" & Cells(Rows.Count, "D").End(xlUp).Row).copy _
ThisWorkbook.Worksheets("Addresses").Range("A" & NextRow)
.Close SaveChanges:=False
End With
Else
MsgBox "File not found: " & Cell.Value
End If
Next Cell
End With
'Call RemoveViaFilter
End Sub
I have never encountered that type of error with NextRow. I know 'Find next blank row and put data there' is a common question, which is why I thought NextRow would solve the issue. However, data is still being overwritten and I have not come across any questions that address this.
I don't want defined ranges (like A2:J100 for example) and have purposefully avoided them, because the length of my lists constantly changes. That goes for the rows I want to paste and the rows of file paths.
Any help is much appreciated, I've used the 'find empty row' several times before with no issues, and don't know why it's overwriting data. It seems antithetical to the whole process of find the empty row.
This is where to you put the additional line...
Option Explicit
Sub AddressListing2()
Dim Cell As Range
Dim NextRow As Long
NextRow = ThisWorkbook.Sheets("Addresses").Range("D" & Rows.Count).End(xlUp).Row + 1
With Worksheets("ghgh")
For Each Cell In .Range("A1", .Cells(.Rows.Count, "A").End(xlUp)).Cells
If Len(Dir(Cell.Value)) Then
With Workbooks.Open(Cell.Value)
Range("A2:X" & Cells(Rows.Count, "D").End(xlUp).Row).copy _
ThisWorkbook.Worksheets("Addresses").Range("A" & NextRow)
.Close SaveChanges:=False
End With
Else
MsgBox "File not found: " & Cell.Value
End If
'Add line here before going to new loop
NextRow = ThisWorkbook.Sheets("Addresses").Range("D" & Rows.Count).End(xlUp).Row + 1
Next Cell
End With
'Call RemoveViaFilter
End Sub
It is clear that NextRow is not being calculated correctly. Put some validation code in after you calculate it:
NextRow = ThisWorkbook.Sheets("Addresses").Range("D" & Rows.Count).End(xlUp).Row + 1
While Application.WorksheetFunction.CountA(Rows(NextRow)) <> 0
NextRow = NextRow + 1
Wend
This will insure NextRow will be an empty row.
The following code works on worksheets labeled Walk INs
Sub Find_Duplicatel()
Dim wrkSht As Worksheet 'The worksheet that you're lookin for duplicates in.
Dim rng As Range 'The range containing the duplicates.
Dim Col As Long 'The last column containing data +1
Set wrkSht = ThisWorkbook.Worksheets("Walk INs")
With wrkSht
'Reference to whole data range.
Set rng = .Range("A5:L2003")
'If the sheet is blank an error will be thrown when trying to find the last column.
'This code looks for the last column - you could just set Col to equal the last column number + 1.
On Error Resume Next
Col = 12
Err.Clear
On Error GoTo 0
If Col = 0 Then Col = 0
'Place a COUNTIF formula in the last column.
rng.Offset(, Col).Columns(1).FormulaR1C1 = "=COUNTIF(" & rng.Columns(1).Address(ReferenceStyle:=xlR1C1) & ",RC" & rng.Column & ") & "" duplicates."""
With rng
'Add conditional formatting to first column in range: If the COUNTIF formula is showing >1 then highlight cell.
With .Columns(1)
'This formula is =VALUE(LEFT($M5,FIND(" ",$M5)-1))>1.
'It returns only the number from the duplicate count and checks it is higher than 1.
.FormatConditions.Add Type:=xlExpression, Formula1:= _
"=VALUE(LEFT(" & rng.Offset(, Col).Cells(1).Address(RowAbsolute:=False) & ",FIND("" ""," & _
rng.Offset(, Col).Cells(1).Address(RowAbsolute:=False) & ")-1))>1"
.FormatConditions(.FormatConditions.Count).SetFirstPriority
.FormatConditions(.FormatConditions.Count).Interior.Color = RGB(0, 100, 255)
End With
'Apply filter to your range.
.AutoFilter
.AutoFilter Field:=12, Criteria1:="Yes"
End With
End With
End Sub`
However when I changed Walk INs to VOC_ASST It hangs up on .AutoFilter I am not certain why. Could you inform me what happened & how to fix it. Other than the sheet titles every thing is identical.
You can add some code it to check if there is an AutoFilter already.
If .AutoFilterMode = False Then
.AutoFilter
.AutoFilter Field:=12, Criteria1:="Yes"
End If
I found the following code on the ENCODEDNA website & after modifying it for my worksheet, it works exactly as I expected.
Sub FIND_DUPLICATE()
`Option Explicit
Dim myDataRng As Range
Dim cell As Range
' WE WILL SET THE RANGE (FIRST COLUMN).
Set myDataRng = Range("A1:A" & Cells(Rows.Count, "B").End(xlUp).Row)
For Each cell In myDataRng
cell.Offset(0, 0).Font.Color = vbBlack ' DEFAULT COLOR.
' LOCATE DUPLICATE VALUE(S) IN THE SPECIFIED RANGE OF DATA.
If Application.Evaluate("COUNTIF(" & myDataRng.Address & "," &
cell.Address & ")") > 1 Then
cell.Offset(0, 0).Font.Color = vbRed ' CHANGE FORE COLOR TO
RED.
End If
Next cell
Set myDataRng = Nothing
ErrHandler:
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub`
Thank you to the people that have assisted me.
I'm trying to create an if statement that checks the colour of column B.
It works if I target a single cell in column B not when I try ("B:B").
This is what I have.
Sub FOO()
Dim answer As Range
Set answer = Range("b:b")
If answer.Interior.Color = vbRed Then
MsgBox ("There is an issue with column B, please review.")
End If
End Sub
As we are getting many quality answers, here is the most optimized code. Fastest, I bet :)
It wont work if you are using one of the ancient versions of excel. anything 2007+ is fine.
Sub OptimizedFOO()
Dim rngTemp
With Application.FindFormat.Interior
.Color = vbRed
End With
'/ Sheet1 is example sheet name
Set rngTemp = Sheet1.Columns(2).Find(What:="", SearchFormat:=True)
If Not rngTemp Is Nothing Then
MsgBox ("There is an issue with column B, please review.")
End If
End Sub
Old answer
Sub FOO()
Dim answer As Range
Dim cell As Range
'/ This will show message if at least one cell is found with red color
Set answer = Range("b:b")
For Each cell In answer.Cells
If answer.Interior.Color = vbRed Then
MsgBox ("There is an issue with column B, please review.")
Exit For
End If
Next
End Sub
I am not sure, but give you my best guess.
If VB unifies the properties, then it unifies the properties of all the cells of the column. You can then compare the property to a value and this will be True if all rhe proeprties have that (same) value. Otherwise the comparison will be False.
So If answer.Interior.Color = vbRed will be True if all cells have this propety value vbRed. If you want to check if any of the cells have that color, you may need to iterate over all the cells.
I believe VB and the VB object model work like this, but again, I am not sure.
I would find last used row on column B and than loop through them.
Sub FOO()
Dim LR As Long, I As Long
LR = findLastRow("Sheet1", "B")
For I = 1 To LR
If Range("B" & I).Interior.Color = vbRed Then
MsgBox ("There is an issue with column B, please review.")
Exit For
End If
Next I
End Sub
Function findLastRow(shtName As String, colLetter As String) As Long
With Sheets(shtName)
If Application.WorksheetFunction.CountA(.Cells) <> 0 Then
findLastRow = .Cells.Find(What:="*", _
After:=.Range(colLetter & "1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
Else
findLastRow = 1
End If
End With
End Function
You could do something using the autofilter, something like this
Function AnyRedCells(rngRangeToInspect As Excel.Range) As Boolean
Application.ScreenUpdating = False
rngRangeToInspect.AutoFilter
rngRangeToInspect.AutoFilter field:=1, Criteria1:=RGB(255, 0, 0), Operator:=xlFilterCellColor
' Using >1 as assuming header on column
AnyRedCells = (ActiveSheet.AutoFilter.Range.SpecialCells(xlCellTypeVisible).Cells.Count > 1)
rngRangeToInspect.AutoFilter
Application.ScreenUpdating = True
End Function
Used like so
Sub OptimizedFOO2()
If AnyRedCells(Range("b23:b26")) Then
MsgBox ("There is an issue with column B, please review.")
End If
End Sub