error im getting this error when using your code
Dim answer As Integer
answer = MsgBox("Äðóêóâàòè?", vbYesNo + vbQuestion, "Äðóê")
If answer = vbYes Then
ActiveSheet.PageSetup.PrintArea = "A1:N27"
ActiveWindow.SelectedSheets.PrintOut
Else
'End
End If
End Sub
need the macro to print areas that are field within range A1:N27 and delete blank can someone solve it?
Due to my fault there where three problems that FaneDuru has found with my workbook that his code didn't worked with my workbook
The rows to be hide/deleted are not empty. They contains formulas...
The result of formula on column D:D is "".
The worksheet in discussion is protected, but without a password
Try the next code, please. It will hide the rows being empty on the range B:L, print and then un-hide them. The updated code is done according to your last specifications (there are formulas in the 'empty' rows, in column D:D the formula result is "" and the worksheet is protected, but without a password):
Sub testRemoveRowsPrintAreaSet()
Dim sh As Worksheet, lastRow As Long, rngDel As Range, i As Long
Set sh = ActiveSheet
lastRow = sh.Range("C" & Rows.Count).End(xlUp).Row
For i = 9 To lastRow
Debug.Print WorksheetFunction.CountBlank(sh.Range("B" & i & ":L" & i))
If WorksheetFunction.CountBlank(sh.Range("B" & i & ":L" & i)) = 10 Then
If rngDel Is Nothing Then
Set rngDel = sh.Range("M" & i)
Else
Set rngDel = Union(rngDel, sh.Range("M" & i))
End If
End If
Next i
If Not rngDel Is Nothing Then
sh.Unprotect
rngDel.EntireRow.Hidden = True
End If
sh.PageSetup.PrintArea = "A1:N" & lastRow
ActiveWindow.SelectedSheets.PrintOut
rngDel.EntireRow.Hidden = False
sh.Protect
End Sub
Please, confirm that it work as you need.
I am attempting to loop through data in a sheet and split them on a comma, when I run the script I get a Run Time Error '1004' Application-Defined or Object defined error.
However, When I step into the script to debug and run it step by step it works perfectly. I was wondering if anyone has seen this and could help me in fixing it.
Sub PopulatePayrollForm()
Dim s As String: s = "Payout Review"
If DoesSheetExists(s) Then
Dim BottomRow As Long
Dim c As Range
Dim splitv() As String
Sheets("Pay Form").Range("A6:AR1000").ClearContents
'Copy to another sheet, Split Columns, Copy and paste full name into 2 cells
Worksheets("Payout Review").Range("A2:A1000").Copy Worksheets("Pay Form").Range("AQ6:AQ1006")
BottomRow = Worksheets("Pay Form").Cells(Rows.Count, "AQ").End(xlUp).Row
Worksheets("Pay Form").Range("AQ6:AQ" & BottomRow).Activate
For Each c In Selection
splitv = Split(c.Value, ",")
If UBound(splitv) > 0 Then
c.Offset(0, -1).Value = splitv(1)
c.Offset(0, -1).Value = c.Offset(0, -1).Value
c.Value = splitv(0)
End If
Next c
Worksheets("Pay Form").Range("AP6:AQ" & BottomRow).Copy Worksheets("Pay Form").Range("C6:C" & BottomRow)
Worksheets("Pay Form").Range("AP6:AQ" & BottomRow).Clear
'Copy and paste Employee Id, Payout AMount, Date Range
Worksheets("Payout Review").Range("B2:B1000").Copy Worksheets("Pay Form").Range("A6:A" & BottomRow)
Worksheets("Payout Review").Range("AB2:AB1000").Copy
Sheets("Pay Form").Range("B6:B" & BottomRow).PasteSpecial xlPasteValues
Worksheets("Payout Review").Range("AD1").Copy Worksheets("Pay Form").Range("J6:J" & BottomRow)
Worksheets("Payout Review").Range("AE1").Copy Worksheets("Pay Form").Range("K6:K" & BottomRow)
Sheets("Pay Form").Visible = True
Else
MsgBox "Data Does not exist"
End If
End Sub
Function DoesSheetExists(sh As String) As Boolean
Dim ws As Worksheet
On Error Resume Next
Set ws = ThisWorkbook.Sheets(sh)
On Error GoTo 0
If Not ws Is Nothing Then DoesSheetExists = True
End Function
The problem is the use of Selection (and Activate):
For Each c In Selection
Just use the Range in question:
For Each c In Worksheets("Pay Form").Range("AQ6:AQ" & BottomRow)
I recommend reading this for a comprehensive discussion of how to avoid Select.
I'm trying to add items from a file saved in path "C:\Users\se72497\Desktop" which contains in the 1st column of the sheet called "Departamentos" a series of values I want to add in the Combobox.
My combobox receive the name of dept.
Private Sub UserForm_Initialize()
Dim filename As Workbook
Set filename = Workbooks.Open("C:\Users\se72497\Desktop\Tablas_Macro.xlsx")
With filename.Sheets("Departamentos")
dept.List = Range("A2", .Range("A" & Rows.Count).End(xlUp).Value)
End With
End Sub
I've tried to execute this code but it returns me a run-time error:
Why vba returns me this error?
The .Value is in the wrong place. (Or you could say that the parenthesis is in the wrong place). Correcting this, you have:
.Range("A2", .Range("A" & Rows.Count).End(xlUp)).Value
With your current code, .Value is within the Range call, so you're trying to use the value of the cell, not the cell itself, as the 2nd argument.
You want it outside.
Otherwise, if the last cell's value is "foo", then your code is equivalent to
Range("A2", "foo")
which is most certainly not what you want.
So when you click pn your combo box data will get loaded,
' Pre-requisties name the cell A2 with variable rstart
Private Sub UserForm_Initialize()
Dim ws As Worksheet: Set ws = Worksheets("Departamentos")
Dim i As Integer: i = 0
Dim lRow As Long
Dim sAddress As String
On Error GoTo errhandling
If Me.nameofcombobox.Value = vbNullString Then
MsgBox "Select value to continue!"
Else
With ws
lRow = .Range("Departamentos").Rows.Count
'name the cell a2 as rstart
Do Until .Range("rStart").Offset(0, i).Value = Me.nameofcombobox.Value
i = i + 1
Loop
sAddress = .Range("rStart").Offset(0, i - 1).Address
.Range(sAddress & ":" & Left(sAddress, 4) & lRow).Value = .Range(sAddress & ":" & Left(sAddress, 4) & lRow).Value
End With
End If
On Error GoTo 0
MsgBox "Completed without errors", vbInformation, "Success"
FunctionOutput:
Set ws = Nothing
Exit Sub
errhandling:
MsgBox "The following error occurred: " & Err.Description, vbCritical, "Error"
Resume FunctionOutput
End Sub
First I need to say that I a beginner with VBA. I understand VBA basics and I already did some little projects but most of it involved a lot of googling.
For the current issue, I could not find any useful tips online. Maybe it's because I created the code on my own. But see for yourself...
I am trying to create a table with client data. The table contains the client number in column "I" which is being added by hand. The table should now pick up other client data such as domicile, age, etc automatically based on the client number from a static database that is in another tab. However, I want to have the possibility to manually overwrite the cells in my table that contain the client data from the database. But when I delete my manual entries the original data from the database should appear again.
With the code below I was able to do this. When a cell is empty the code adds a formula to the cell that picks up the data from the database. However, I am able to overwrite the formula manually. When I delete my manual entry and the cell becomes empty again the formula appears again and picks up the data from the database. But I have two problems with the code below:
The code seems to be too "heavy". For example, when I delete rows, I get an error message "Not enough system resource to display completely" which freezes the complete Excel file.
When I add new client numbers in column "I" the code does not pick up the data from the database automatically. I need to trigger the Worksheet_Change for every single cell by choosing the cell and clicking Delete
So I am looking for a way to simplify my code so that:
the error message does not occur again when I am deleting rows;
when I add a new client number in column "I" the other cells in the same row should instantly pickup other client data from the database.
I already tried the following but without success:
To delete rows I created a code that does it automatically and I added Application.EnableEvents = False at the beginning of the code and Application.EnableEvents = True at the end with the intention to stop the Worksheet_Change while the rows are being deleted but it did not work and I still got an error.
To trigger the Worksheet_Change I used the following code Application.Run "Sheet3.Worksheet_Change", Range("A1:Z5000") and assigned it to a button but it did not work.
So here is the existing code (note the code look longer than it is. The code for every column is the same, only the formulas is different that is being put into the cells are different):
Private Sub Worksheet_Change(ByVal Target As Range)
'Code for column B
Dim AffectedRange As Range
Set AffectedRange = Intersect(Target, Me.Range("B2:B" & Me.Rows.Count))
If Not AffectedRange Is Nothing Then
Dim iCell As Range
For Each iCell In AffectedRange.Cells
If iCell.Value = vbNullString Then
iCell.Formula = "=IFERROR(IF($I" & iCell.Row & "="""","""",VLOOKUP($I" & iCell.Row & ",'Raw Data'!$A$1:$AH$5000,4,FALSE)),""N/A"")"
End If
Next iCell
End If
'Code for column D
Dim AffectedRange1 As Range
Set AffectedRange1 = Intersect(Target, Me.Range("D2:D" & Me.Rows.Count))
If Not AffectedRange1 Is Nothing Then
Dim iCell1 As Range
For Each iCell1 In AffectedRange1.Cells
If iCell1.Value = vbNullString Then
iCell1.Formula = "=IFERROR(IF($I" & iCell1.Row & "="""","""",IF(VLOOKUP($I" & iCell1.Row & ",'Raw Data'!$A$1:$AH$5000,9,FALSE)=0,""N/A"",VLOOKUP($I" & iCell1.Row & ", 'Raw Data'!$A$1:$AH$5000,9,FALSE))),""N/A"")"
End If
Next iCell1
End If
'Code for column E
Dim AffectedRange2 As Range
Set AffectedRange2 = Intersect(Target, Me.Range("E2:E" & Me.Rows.Count))
If Not AffectedRange2 Is Nothing Then
Dim iCell2 As Range
For Each iCell2 In AffectedRange2.Cells
If iCell2.Value = vbNullString Then
iCell2.Formula = "=IFERROR(IF($I" & iCell2.Row & "="""","""",IF(VLOOKUP($I" & iCell2.Row & ",'Raw Data'!$A$1:$AH$5000,10,FALSE)=0,""N/A"",VLOOKUP($I" & iCell2.Row & ", 'Raw Data'!$A$1:$AH$5000,10,FALSE))),""N/A"")"
End If
Next iCell2
End If
'Code for column C
Dim AffectedRange4 As Range
Set AffectedRange4 = Intersect(Target, Me.Range("C2:C" & Me.Rows.Count))
If Not AffectedRange4 Is Nothing Then
Dim iCell4 As Range
For Each iCell4 In AffectedRange4.Cells
If iCell4.Value = vbNullString Then
iCell4.Formula = "=IFERROR(IF($I" & iCell4.Row & "="""","""",IF(VLOOKUP($I" & iCell4.Row & ",'Raw Data'!A$1:$AH$5000,22,FALSE)=0,""N/A"",IF(VLOOKUP($I" & iCell4.Row & ",'Raw Data'!A$1:$AH$5000,22,FALSE)<0.49999,""Prio 3"",IF(AND(VLOOKUP($I" & iCell4.Row & ",'Raw Data'!A$1:$AH$5000,22,FALSE)>0.49999,VLOOKUP($I" & iCell4.Row & ",'Raw Data'!A$1:$AH$5000,22,FALSE)<0.79999),""Prio 2"",IF(VLOOKUP($I" & iCell4.Row & ",'Raw Data'!A$1:$AH$5000,22,FALSE)>0.79999,""Prio 1"",""N/A""))))),""N/A"")"
End If
Next iCell4
End If
'Code for column H
Dim AffectedRange5 As Range
Set AffectedRange5 = Intersect(Target, Me.Range("H2:H" & Me.Rows.Count))
If Not AffectedRange5 Is Nothing Then
Dim iCell5 As Range
For Each iCell5 In AffectedRange5.Cells
If iCell5.Value = vbNullString Then
iCell5.Formula = "=IFERROR(IF($I" & iCell5.Row & "="""","""",IF(VLOOKUP($I" & iCell5.Row & ",'Raw Data'!$A$1:$AH$5000,11,FALSE)=0,""N/A"",VLOOKUP($I" & iCell5.Row & ", 'Raw Data'!$A$1:$AH$5000,11,FALSE))),""N/A"")"
End If
Next iCell5
End If
'Code for column F
Dim AffectedRange6 As Range
Set AffectedRange6 = Intersect(Target, Me.Range("F2:F" & Me.Rows.Count))
If Not AffectedRange6 Is Nothing Then
Dim iCell6 As Range
For Each iCell6 In AffectedRange6.Cells
If iCell6.Value = vbNullString Then
iCell6.Formula = "=IFERROR(IF($I" & iCell6.Row & "="""","""",(IF(OR($D" & iCell6.Row & "=""N/A"",$D" & iCell6.Row & "=""""),""N/A"",IF(AND($H" & iCell6.Row & "=""Espagne"",LEN($D" & iCell6.Row & ")=5),VLOOKUP(LEFT($D" & iCell6.Row & ",2),Regionslist!$A$1:$B$52,2,FALSE),IF(AND($H" & iCell6.Row & "=""Espagne"",LEN($D" & iCell6.Row & ")=4),VLOOKUP(""0""&LEFT($D" & iCell6.Row & ",1),Regionslist!$A$1:$B$52,2,FALSE),$H" & iCell6.Row & "))))),$H" & iCell6.Row & ")"
End If
Next iCell6
End If
'Code for column G
Dim AffectedRange7 As Range
Set AffectedRange7 = Intersect(Target, Me.Range("G2:G" & Me.Rows.Count))
If Not AffectedRange7 Is Nothing Then
Dim iCell7 As Range
For Each iCell7 In AffectedRange7.Cells
If iCell7.Value = vbNullString Then
iCell7.Formula = "=IFERROR(IF($I" & iCell7.Row & "="""","""",VLOOKUP($F" & iCell7.Row & ",Regionslist!$B$1:$C$52,2,FALSE)),$F" & iCell7.Row & ")"
End If
Next iCell7
End If
'Code for column J
Dim AffectedRange8 As Range
Set AffectedRange8 = Intersect(Target, Me.Range("J2:J" & Me.Rows.Count))
If Not AffectedRange8 Is Nothing Then
Dim iCell8 As Range
For Each iCell8 In AffectedRange8.Cells
If iCell8.Value = vbNullString Then
iCell8.Formula = "=IFERROR(IF($I" & iCell8.Row & "="""","""",VLOOKUP($I" & iCell8.Row & ",'Raw Data'!$A$1:$AH$5000,2,FALSE)),""N/A"")"
End If
Next iCell8
End If
'Code for column K
Dim AffectedRange9 As Range
Set AffectedRange9 = Intersect(Target, Me.Range("K2:K" & Me.Rows.Count))
If Not AffectedRange9 Is Nothing Then
Dim iCell9 As Range
For Each iCell9 In AffectedRange9.Cells
If iCell9.Value = vbNullString Then
iCell9.Formula = "=IFERROR(IF($I" & iCell9.Row & "="""","""",IF(SUBSTITUTE(VLOOKUP($I" & iCell9.Row & ",'Raw Data'!$A$1:$AH$5000,13,FALSE),"","","""")<>"""",SUBSTITUTE(VLOOKUP($I" & iCell9.Row & ",'Raw Data'!$A$1:$AH$5000,13,FALSE),"","",""""),""N/A"")),""N/A"")"
End If
Next iCell9
End If
'Code for column L
Dim AffectedRange10 As Range
Set AffectedRange10 = Intersect(Target, Me.Range("L2:L" & Me.Rows.Count))
If Not AffectedRange10 Is Nothing Then
Dim iCell10 As Range
For Each iCell10 In AffectedRange10.Cells
If iCell10.Value = vbNullString Then
iCell10.Formula = "=IFERROR(IF($I" & iCell10.Row & "="""","""",SUBSTITUTE(VLOOKUP($I" & iCell10.Row & ",'Raw Data'!$A$1:$AH$5000,20,FALSE),"","","""")),""N/A"")"
End If
Next iCell10
End If
'Code for column M
Dim AffectedRange11 As Range
Set AffectedRange11 = Intersect(Target, Me.Range("M2:M" & Me.Rows.Count))
If Not AffectedRange11 Is Nothing Then
Dim iCell11 As Range
For Each iCell11 In AffectedRange11.Cells
If iCell11.Value = vbNullString Then
iCell11.Formula = "=IFERROR(IF($I" & iCell11.Row & "="""","""",VLOOKUP($I" & iCell11.Row & ",'Raw Data'!$A$1:$AH$5000,22,FALSE)),""N/A"")"
End If
Next iCell11
End If
'Code for column N
Dim AffectedRange12 As Range
Set AffectedRange12 = Intersect(Target, Me.Range("N2:N" & Me.Rows.Count))
If Not AffectedRange12 Is Nothing Then
Dim iCell12 As Range
For Each iCell12 In AffectedRange12.Cells
If iCell12.Value = vbNullString Then
iCell12.Formula = "=IFERROR(IF($I" & iCell12.Row & "="""","""",""1.""&VLOOKUP($I" & iCell12.Row & ",'Raw Data'!$A$1:$AH$5000,21,FALSE)),""N/A"")"
End If
Next iCell12
End If
'Code for column W
Dim AffectedRange13 As Range
Set AffectedRange13 = Intersect(Target, Me.Range("W2:W" & Me.Rows.Count))
If Not AffectedRange13 Is Nothing Then
Dim iCell13 As Range
For Each iCell13 In AffectedRange13.Cells
If iCell13.Value = vbNullString Then
iCell13.Formula = "=IF($I" & iCell13.Row & "="""","""",IFERROR(IF(VLOOKUP($I" & iCell13.Row & ",'Raw Data'!$A$1:$AH$5000,1,FALSE)=$I" & iCell13.Row & ",""yes"",""no""),""no""))"
End If
Next iCell13
End If
End sub
In advance many thanks for any kind of advice and help!
Best regards,
Oliver
You code doesn't check for changes in Col I, so you could add a block for that
'Code for column B
Dim AffectedRange As Range
Set AffectedRange = Intersect(Target, Me.Range("I2:I" & Me.Rows.Count))
If Not AffectedRange Is Nothing Then
Dim iCell As Range
For Each iCell In AffectedRange.Cells
Application.EnableEvents=false
'Note the Range is *relative* to EntireRow
iCell.EntireRow.range("B1:H1,J1:M1").value = 1 'set an initial value
Application.EnableEvents=True
'Then trigger a change to set the formulas
iCell.EntireRow.range("B1:H1,J1:M1").ClearContents
Next iCell
End I
My macro currently works by pressing CTRL+F to open the search box which searches either REF1 or REF2. If the information is found, it copies over to the next cell basically to show it's there. If the information is not found, it pastes the data searched for in cell L4 so a label can be printed.
What I'm trying to do:
Remove the CTRL+F and basically run from a cell (let's say cell L18). However, when scanned the scanner basically types in the numbers then presses enter/return.
I was wondering, would it be possible to make it run like this.
Select cell L18 then keep scanning until either:
A) The list is done - nothing is missing
B) If REF1/REF2 doesn't match, pastes that data into cell L4 for a label to be printing.
(Current version using CTRL+F): http://oi39.tinypic.com/mima9x.jpg
(Example of what I need): http://oi42.tinypic.com/24fiwt1.jpg
Current macro:
Sub Extra_Missing_Item() Application.ScreenUpdating = False
Dim rangeToSearch As Range
With Sheets(1)
Set rangeToSearch = .Range("A2:B" & .Range("A" & .Rows.Count).End(xlUp).Row)
End With
Dim searchAmount As String
searchAmount = InputBox("Scan the REF1 or REF2:")
Dim cell As Range
Set cell = rangeToSearch.Find(searchAmount, LookIn:=xlValues)
With Sheets(1)
If Not cell Is Nothing Then
.Range("E" & cell.Row & ":G" & cell.Row).Value = _
.Range("A" & cell.Row & ":C" & cell.Row).Value
Else
MsgBox "REF1/REF2: " & searchAmount & " shouldn't be here"
.Range("L4").Value = searchAmount
Range("L9").Select
End If
End With
Application.ScreenUpdating = True
End Sub
I think I understand what you need. This macro calls each time any cell on the sheet changed (but if changed cell is not L18, macro do nothing):
Private Sub Worksheet_Change(ByVal Target As Range)
If Application.Intersect(Target, Range("L18")) Is Nothing Then
Exit Sub
End If
Dim rangeToSearch As Range
Dim searchAmount As String
Dim cell As Range
Application.ScreenUpdating = False
Application.EnableEvents = False
Set rangeToSearch = Range("A2:B" & Range("A" & Rows.Count).End(xlUp).Row)
searchAmount = Target.value
Set cell = rangeToSearch.Find(searchAmount, LookIn:=xlValues)
If Not cell Is Nothing Then
Range("E" & cell.Row & ":G" & cell.Row).value = _
Range("A" & cell.Row & ":C" & cell.Row).value
Else
MsgBox "REF1/REF2: " & searchAmount & " shouldn't be here"
Range("L4").value = searchAmount
End If
Range("L18").Select
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
Put this macro in the Sheet module (coresponding to the sheet where your data is):