i am new to VBA what i want to do is if cell column A is empty then cell in column B should also be empty and if cell column A as values then cell in columns B should have value in same row. if not meet then msg box error my code is below i have problems with 2nd of that condition its not showing me error when i have value in cell in column B but column A is empty. Pls help
Sub Denial_Reason1()
Dim ws As Worksheet: Set ws = ThisWorkbook.Sheets("Sheet3")
Dim lr As Long, target As Range
lr = ws.Range("A" & ws.Rows.Count).End(xlUp).Row
For Each target In ws.Range("A2:A" & lr)
If target <> "" And target.Offset(0, 1) = "" Then
MsgBox "Error" & target.Address
enter code here
ElseIf target = "" And target.Offset(0, 1) <> "" Then
MsgBox "Error" & target.Address
End If
Next target
End Sub
You can do something like this:
Sub Denial_Reason1()
Dim ws As Worksheet
Dim c As Range, vA, vB
Set ws = ThisWorkbook.Sheets("Sheet3")
For Each c In ws.Range("A2:A" & ws.Range("A" & ws.Rows.Count).End(xlUp).Row)
vA = Len(c.Value)
vB = Len(c.Offset(0, 1).Value)
If (vA > 0 And vB = 0) Or (vA = 0 And vB > 0) Then
MsgBox "Mismatch error at " & c.Resize(1, 2).Address
End If
Next c
End Sub
Related
I am trying to do the macro which can do autofilter and copy the visible row , then paste them into the new sheet by using VBA. my code as below:
Option Explicit
Sub lab()
Dim ws As Worksheet
Dim sh1 As Worksheet
Dim mycoll As Collection
Set mycoll = New Collection
Set sh1 = ThisWorkbook.Sheets(1)
Dim rng As Range
Dim c As Range
Dim lastrow As Long
lastrow = Range("C" & Rows.Count).End(xlUp).Row
On Error Resume Next
Set rng = sh1.Range("B4:F" & lastrow)
With rng
.AutoFilter field:=2, Criteria1:=sh1.Range("I1"), Criteria2:=sh1.Range("I2"), Operator:=xlOr
.AutoFilter field:=3, Criteria1:=sh1.Range("K1"), Criteria2:=sh1.Range("K2"), Operator:=xlOr
.AutoFilter field:=4, Criteria1:=sh1.Range("M1"), Criteria2:=sh1.Range("M2"), Operator:=xlOr
End With
Set ws = Worksheets.Add
ws.Name = sh1.Range("I1").Value & "-" & sh1.Range("I2").Value
rng.SpecialCells(xlCellTypeVisible).Copy ws.Range("A1")
rng.AutoFilter
sh1.Activate
End Sub
my problem is the code only work correctly for the first new sheet. then it always create the sheet with the same content. I tried to find the root issue , could you please help assist on this ?
When there is a problem with your code, you never use On Error Resume Next! It only does not let VBA 'telling' you what problem the code has...
If your code names the newly created sheet using:
ws.Name = sh1.Range("I1").Value & "-" & sh1.Range("I2").Value
second time, if the concatenation of the two cells value is the same, VBA cannot name a sheet with the same name like an existing one. The raised error should have a clear description but your code jumps over it, because of On error Resume Next.
If you really need/want to use a similar sheet name, try placing a sufix. For doing that, you can use the next function:
Function shName(strName As String) As String
Dim ws As Worksheet, arrSh, arrN, maxN As Long, k As Long, El
ReDim arrSh(ActiveWorkbook.Sheets.count - 1)
For Each ws In ActiveWorkbook.Sheets
If ws.Name = strName Then
shName = strName & "_" & 1
Exit Function
End If
If InStr(ws.Name, strName & "_") > 0 Then arrSh(k) = ws.Name: k = k + 1
Next
If k = 0 Then shName = strName: Exit Function 'if no such a name exists
ReDim Preserve arrSh(k - 1)
'determine the bigger suffix:
For Each El In arrSh
arrN = Split(El, "_")
If CLng(arrN(UBound(arrN))) > maxN Then maxN = CLng(arrN(UBound(arrN)))
Next
shName = strName & "_" & maxN + 1
End Function
It should be called from your existing code replacing the line
ws.Name = sh1.Range("I1").Value & "-" & sh1.Range("I2").Value
with
ws.Name = shName(sh1.Range("I1").Value & "-" & sh1.Range("I2").Value)
I'm working to identify rows in sheet 1 that are not blank in column A and don't have a Y or L in column V. Then I need to copy the contents of that row, then paste values to an open row on the next worksheet. Lastly, I need to clear contents on the original sheet for that row. I'm getting stuck when it comes time to paste. Error 1004 - Method 'Range' of object'_Worksheet' failed. I appreciate any help.
Option Explicit
Option Compare Text
Sub EndMove()
Dim rowCount As Long, i As Long
Dim ws As Worksheet: Set ws = ActiveSheet
ws.Range("A11").Select
rowCount = ws.Cells(ws.Rows.Count, 1).End(xlUp).row
Application.ScreenUpdating = False: Application.EnableEvents = False
Call ShowAllRecords
For i = 11 To rowCount
If ws.Range("V" & i) <> "y" And ws.Range("V" & i) <> "l" Then
If ws.Range("A" & i) <> "" Then
Dim rowCount2 As Long, j As Long
Dim sRng As Range
Dim ws2 As Worksheet: Set ws2 = ThisWorkbook.Sheets(ActiveSheet.Index + 1)
Dim wAct As Worksheet
Dim lRow As Long
Dim End_Row As Long
Set wAct = ws
Set sRng = ws.Range("V" & i)
If Not IsDate("01 " & wAct.Name & " 2017") Or wAct.Name = "Dec" Then MsgBox "Not applicable for this sheet.": Exit Sub
If ActiveSheet.Index = ThisWorkbook.Worksheets.Count Then MsgBox "This is the last worksheet cannot move forward.": Exit Sub
wAct.unprotect
With ws2
.unprotect
If rowCount2 = "1" Then
For j = 11 To Rows.Count
If .Range("A" & j) = "" Then
End_Row = j
Exit For
End If
Next j
Else
End If
wAct.Range("A" & sRng.row & ":AD" & sRng.row + sRng.Rows.Count - 1).Copy
.Range("A" & End_Row).PasteSpecial xlPasteValuesAndNumberFormats
wAct.Range("A" & sRng.row & ":AD" & sRng.row + sRng.Rows.Count - 1).ClearContents
.Range("A1000").Value = End_Row
.protect DrawingObjects:=True, Contents:=True, Scenarios:=True, AllowFiltering:=True
End With
wAct.protect DrawingObjects:=True, Contents:=True, Scenarios:=True, AllowFiltering:=True
Application.CutCopyMode = False
End If
End If
Next i
Application.EnableEvents = True: Application.ScreenUpdating = True
Call FilterBlanks
MsgBox "Move Complete"
End If
End Sub
It seems there is no line in your code that would assign value to rowCount2. So when you check it in code below it gives always false and therefore skips this part
If rowCount2 = "1" Then
For j = 11 To Rows.Count
If .Range("A" & j) = "" Then
End_Row = j
Exit For
End If
Next j
Else
but that part is essential as it is the only part where End_Row is assigned value. So then when you try to do this .Range("A" & End_Row) there is nothing in End_Row. Set up a breakpoint on that line and check Locals screen for End_Row to make sure it is this.
I am trying to make a sales sheet in excel for a point of sale. I need:
When a barcode is entered into cell A5 onwards, I would like cell D5 onwards to update with a default quantity of '1', and
If the barcode is then removed, the quantity should be cleared too.
I am able to achieve #1 but not #2. I have the below code so far, can anyone help?
Sub SetQuantity()
Dim LastRow As Long
Dim i As Long
LastRow = Range("A" & Rows.Count).End(xlUp).Row
For i = 5 To LastRow
If Not IsEmpty(Range("A" & i).Value) Then
Range("D" & i).Value = 1
Else: DeleteQuantity
End If
Next i
End Sub
Sub DeleteQuantity()
Dim LastRow As Long
Dim i As Long
LastRow = Range("A" & Rows.Count).End(xlUp).Row
For i = 5 To LastRow
If Range("A" & i).Value = "" Then
Range("D" & i).Value = ""
End If
Next i
End Sub
Something like this would avoid all the looping and might work better -
Sub worksheet_change(ByVal Target As Range)
Dim lastrow As Integer
lastrow = Range("A" & Rows.Count).End(xlUp).Row
If Not Intersect(Target, Range("A5:A" & lastrow)) Is Nothing Then
If IsEmpty(Target) Then
Target.Offset(, 3) = vbNullString
Else: Target.Offset(, 3) = 1
End If
End If
End Sub
You'd just place it in the sheet module for the sheet you want to watch.
Put this code in the sheet module:
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column = 1 And Target.Rows.Count = 1 And Target.Columns.Count = 1 Then
If Not IsEmpty(Target.Value) Then
Cells(Target.Row, 4) = 1
Else
Cells(Target.Row, 4).ClearContents
End If
End If
End Sub
Scenario: Each row would contain 23 columns; 20 would contain user populated data and the last 3 would be autogenerated through vba.
While running if the vba code identifies the first 20 columns of any row to be blank cells then the whole row is declared blank and highlighted.
I have been able to write the following code:
For Each rng In Range("A1:A" & LastRow)
With rng
If .Value < 1 Then
MsgBox "Blank Cell found"
blnkcnt = 0
For Each mycl In Range("A" & ActiveCell.Row & ":T" & ActiveCell.Row)
With mycl
If .Value < 1 Then
blnkcnt = blnkcnt + 1
End If
End With
Next mycl
If blnkcnt = 20 Then
lCount = lCount + 1
With .EntireRow.Interior
.ColorIndex = 6
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
End With
End If
End If
End With
Next rng
If lCount > 0 Then
MsgBox "Data contains blank row(s): " & lCount
End
Else
MsgBox "No blank Rows"
End If
I've used a COUNTBLANK function on the first 20 columns of each row to determine if any blank cells exist.
Dim rng As Range, lCount As Long, LastRow As Long
With ActiveSheet 'set this worksheet properly!
LastRow = .Cells(Rows.Count, 1).End(xlUp).Row
For Each rng In .Range("A1:A" & LastRow)
With rng.Resize(1, 20)
If Application.CountBlank(.Cells) = 20 Then 'All 20 cells are blank
lCount = lCount + 1
.EntireRow.ClearContents
.EntireRow.Interior.ColorIndex = 6
End If
End With
Next rng
End With
If lCount > 0 Then
MsgBox "Data contains blank row(s): " & lCount
Else
MsgBox "No blank Rows"
End If
If all 20 cells are blank then the entire row is made blank and yellow highlighting is applied.
I'm using the COUNTBLANK function as it was not clear on whether you have zero-length strings returned by formulas. COUNTBLANK will count these as blanks.
Don't use that. Use CountA to check if there is any data in those 20 columns.
See this (untested)
Dim ws As Worksheet
Dim i As Long
'~~> Change this to the relevant worksheet
Set ws = ThisWorkbook.Sheets("Sheet1")
With ws
'~~> Find lastrow and change accordingly
'~~> For demonstration purpose using a hard coded value
lastrow = 10
For i = 1 To lastrow
'~~> Use CountA to check if there is any data
If Application.WorksheetFunction.CountA(.Range("A" & i & ":T" & i)) = 0 Then
MsgBox "Row " & i & " is blank"
'
'~~> Rest os your code
'
End If
Next i
End With
Hi all I need to selectively copy entire rows from sheet1 to other sheet. As of now I am using checkboxes to select the rows and then copy the selected rows to sheet of user's choice. But I am facing a bizarre error. For sometime the code runs fine, copying exact data to sheets but after some time it copies erroneous values from nowhere. Can you please help me with this? Pasting the code I am using.
Sub Addcheckboxes()
Dim cell, LRow As Single
Dim chkbx As CheckBox
Dim MyLeft, MyTop, MyHeight, MyWidth As Double
Application.ScreenUpdating = False
LRow = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row
For cell = 2 To LRow
If Cells(cell, "A").Value <> "" Then
MyLeft = Cells(cell, "E").Left
MyTop = Cells(cell, "E").Top
MyHeight = Cells(cell, "E").Height
MyWidth = Cells(cell, "E").Width
ActiveSheet.CheckBoxes.Add(MyLeft, MyTop, MyWidth, MyHeight).Select
With Selection
.Caption = ""
.Value = xlOff
.Display3DShading = False
End With
End If
Next cell
Application.ScreenUpdating = True
End Sub
Sub RemoveCheckboxes()
Dim chkbx As CheckBox
For Each chkbx In ActiveSheet.CheckBoxes
chkbx.Delete
Next
End Sub
Sub CopyRows()
Dim Val As String
Val = InputBox(Prompt:="Sheet name please.", _
Title:="ENTER SHEET NAME", Default:="Sheet Name here")
For Each chkbx In ActiveSheet.CheckBoxes
If chkbx.Value = 1 Then
For r = 1 To Rows.Count
If Cells(r, 1).Top = chkbx.Top Then
With Worksheets(Val)
LRow = .Range("A" & Rows.Count).End(xlUp).Row + 1
.Range("A" & LRow & ":AF" & LRow) = _
Worksheets("Usable_Inv_Data").Range("A" & r & ":AF" & r).Value
End With
Exit For
End If
Next r
End If
Next
End Sub
Normal Copy Output:
Erroneous Copy Output for same values:
Doing a quick comparison of the normal and the erroneous outputs, it looks like some of your cells/columns are not formatted correctly in your destination sheet (where you are "pasting" the values).
For example, your Base Change column in the Normal copy (the value 582.16) is formatted as a General or Number. The same column in the destination sheet is formatted as a date (582.16 converted to a date value in Excel will be 8/4/1901, or 8/4/01, as shown in your screen.
Just make sure the columns are formatted to display the data type you expect. On your destination sheet, select the column, right-click "Format Cells", and then select the appropriate data type.
---EDIT---
To automate the formatting, you would have to copy and paste the values, inclusive of the formats. Your code would change from this:
With Worksheets(Val)
LRow = .Range("A" & Rows.Count).End(xlUp).Row + 1
.Range("A" & LRow & ":AF" & LRow) = _
Worksheets("Usable_Inv_Data").Range("A" & r & ":AF" & r).Value
End With
TO
With Worksheets(Val)
LRow = .Range("A" & Rows.Count).End(xlUp).Row + 1
Worksheets("Usable_Inv_Data").Range("A" & r & ":AF" & r).Copy
.Range("A" & LRow).PasteSpecial (xlPasteValuesAndNumberFormats)
End With
I have added the checkbox with LinkedCell property. This helps to identify the rows when checkbox is checked.
Also i have added a function check_worksheet_exists which will check if the workbook exist.
Sub Addcheckboxes()
Dim cell, LRow As Single
Dim chkbx As CheckBox
Dim MyLeft, MyTop, MyHeight, MyWidth As Double
Application.ScreenUpdating = False
LRow = ActiveSheet.Range("A" & Rows.Count).End(xlUp).row
For cell = 2 To LRow
If Cells(cell, "A").Value <> "" Then
MyLeft = Cells(cell, "E").Left
MyTop = Cells(cell, "E").Top
MyHeight = Cells(cell, "E").Height
MyWidth = Cells(cell, "E").Width
ActiveSheet.CheckBoxes.Add(MyLeft, MyTop, MyWidth, MyHeight).Select
With Selection
.Caption = ""
.Value = xlOff
.Display3DShading = False
.LinkedCell = Cells(cell, "AZ").Address
End With
End If
Next cell
Application.ScreenUpdating = True
End Sub
Sub RemoveCheckboxes()
Dim chkbx As CheckBox
For Each chkbx In ActiveSheet.CheckBoxes
chkbx.Delete
Next
End Sub
Sub CopyRows()
Dim Val As String
Dim row As Long
Val = InputBox(Prompt:="Sheet name please.", Title:="ENTER SHEET NAME", Default:="Sheet Name here")
If check_worksheet_exists(ThisWorkbook, Val, False) = False Then
Exit Sub
End If
For Each chkbx In ActiveSheet.CheckBoxes
If chkbx.Value = 1 Then
row = Range(chkbx.LinkedCell).row
With Worksheets(Val)
LRow = .Range("A" & Rows.Count).End(xlUp).row + 1
.Range("A" & LRow & ":AF" & LRow) = ActiveSheet.Range("A" & row & ":AF" & row).Value
End With
End If
Next
End Sub
Function check_worksheet_exists(tBook As Workbook, ByVal check_sheet As String, Optional no_warning As Boolean = False) As Boolean
On Error Resume Next
Dim wkSht As Worksheet
Set wkSht = tBook.Sheets(check_sheet)
If Not wkSht Is Nothing Then
check_worksheet_exists = True
ElseIf wkSht Is Nothing And no_warning = False Then
MsgBox "'" & check_sheet & "' sheet does not exist", vbCritical, "Error"
End If
On Error GoTo 0
End Function
i cannot immediately see the errors you refer to, unless you are referring to the sequences of hash-signs ###? These just indicate that the columns aren't wide enough.
Worksheets(Val).Range("A1").CurrentRegion.EntireColumn.AutoFit
BTW I don't think Val is a sensible variable name ;)