I'm using a VBA script to fill a column with some data.
This script checks for the first free cell in a range and fill it with the data from another Excel worksheet.
The script starts when user double clicks on a data-cell in the other sheet.
The code of the VBA script is:
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Dim ws2 As Worksheet
Dim cognome As Range
Dim ultB As Long
Set cognome = Me.Range("A:A")
Set ws2 = ThisWorkbook.Sheets("PUBBLICO")
ultB = IIf(ws2.Range("E8").Value = "", 8, ws2.Range("E7").End(xlDown).Row + 1)
If Not Intersect(Target, cognome) Is Nothing And Target.Value <> "" Then
ws2.Range("E" & ultB).Value = Me.Range("B" & Target.Row).Value 'ANNO
ws2.Range("F" & ultB).Value = Me.Range("A" & Target.Row).Value 'COGNOME
'ws2.Range("E4").Value = Me.Range("C" & Target.Row).Value NOME SQUADRA
End If
Set ws2 = Nothing
Cancel = True
End Sub
The problem is that this script should be optimized for another use. I've another Excel sheet that into the range of cell to fill contains a cell that is always pre-filled and it is merged.
This is the example of my Excel file:
As you can see, row 19 is always pre-filled.
So, any suggestions to correct my script to jump row 19?
Consider
ultB = IIf(ws2.Range("E8").Value = "", 8, ws2.Range("E27").End(xlUp).Row + 1)
If ultB = 19 Then ultB = 20
If ultB = 27 Then
MsgBox "Form is full"
Exit Sub
End If
If Not Intersect(Target, cognome) Is Nothing And Target.Value <> "" Then
This will find the last populated cell from the bottom up instead of from the top down. It also contains some code to notify when the form is full.
Related
I am trying to create a VBA macro to fill in cells that are empty in a range ("INV_Nums") without overwriting the cell if it contains data already. In order to accomplish this I am trying to use an if statement to check if the cell in question is blank...if it is not, then I want the loop to continue on to the next cell, however if it IS blank then I want to input the index(__,(match()) function into the cell.
I keep getting a "compile error: mismatch" on the True statement but I'm at a loss as to why my synatax would be wrong. Any help would be appreciated.
Here is my code:
Dim i As Integer
Dim Rng As Range
Dim ARwkb As Excel.Workbook
Dim ARwks As Excel.Worksheet
Dim Samwkb As Excel.Workbook
Dim Samwks As Excel.Worksheet
Set Samwkb = Excel.Workbooks("Samples - one sheet")
Set Samwks = Samwkb.Worksheets("samples shipment")
Set ARwkb = Excel.Workbooks("AR balance.xlsx")
Set ARwks = ARwkb.Worksheets("Total Trading")
Set Rng = Samwkb.Range("INV_Nums")
For i = 6 To Rng.Rows.Count + 6
If Range("AAi") = "" Is True Then
Range("AAi").Select
ActiveCell.FormulaR1C1 = _
"=INDEX('AR balance.xlsx'!AR_Invoice_Nums,MATCH(RC[-21],'AR
balance.xlsx'!AR_PL_Nums,0))"
End If
Next i
The problem is in how you are identifying the range and administering the criteria.
For i = 6 To Rng.Rows.Count + 6
If IsEmpty(Range("AA" & i)) Then
Range("AA" & i).FormulaR1C1 = _
"=INDEX('AR balance.xlsx'!AR_Invoice_Nums, MATCH(RC[-21],'AR balance.xlsx'!AR_PL_Nums, 0))"
End If
Next i
The .SpecialCells method can quickly determine the blank cells and an xlR1C1 formula can be used to insert all of the formulas at once..
...
with Samwkb.Range("INV_Nums")
.specialcells(xlcelltypeblanks).FormulaR1C1 = _
"=INDEX('AR balance.xlsx'!AR_Invoice_Nums, MATCH(RC[-21],'AR balance.xlsx'!AR_PL_Nums, 0))"
end with
...
Wondering if someone can help me reverse the below code. Essentially, I have a userform with a combobox that generates from a list of names from a worksheet column "A". Upon submit the selected items from userform are populated to the worksheet to the row of the corresponding name from the combobox.
I am hoping to somehow reverse the code below so I can place it in "UserForm_Initialize()" to regenerate saved values back to the texboxes on the form if user closes and reopens the same day. I have a current date textbox called "currentDate". So basically if Date = currentDate.Text Than...add cell value back to textboxes.
Dim dn As Worksheet: Set dn = Sheets("DailyNumbers")
Dim EmptyRow As Long
Dim FoundVal As Range
EmptyRow = dn.Cells(ws.Rows.Count, "B").End(xlUp).Row + 1
' *** Check combobox selection ***
If procNamecombobox.ListIndex > -1 Then
Set FoundVal = dn.Range("A1:A" & EmptyRow).Find (procNamecombobox.Value) 'find Combobox value in Column A
If Not FoundVal Is Nothing Then 'if found
dn.Range("B" & FoundVal.Row).Value = currentDate.Text
dn.Range("C" & FoundVal.Row).Value = completeCount.Text 'use that row to populate cells
dn.Range("D" & FoundVal.Row).Value = handledCount.Text
dn.Range("E" & FoundVal.Row).Value = wipCount.Text
dn.Range("F" & FoundVal.Row).Value = suspendCount.Text
Else 'if not found use EmptyRow to populate Cells
dn.Range("A" & EmptyRow).Value = procNamecombobox.Value
dn.Range("B" & EmptyRow).Value = currentDate.Text
dn.Range("C" & EmptyRow).Value = completeCount.Text
dn.Range("D" & EmptyRow).Value = handledCount.Text
dn.Range("E" & EmptyRow).Value = wipCount.Text
dn.Range("F" & EmptyRow).Value = suspendCount.Text
End If
Else
MsgBox "Please select your name"
End If
Thank you!
I guess you could use something like this
Option Explicit
Private Sub UserForm_Initialize()
Dim f As Range
With Worksheets("DailyNumbers") 'reference wanted sheet
Set f = .Range("B1", .Cells(.Rows.Count, "B").End(xlUp)).Find(Date, lookat:=xlWhole, LookIn:=xlValues) 'search referenced sheet column B for current date
End With
If Not f Is Nothing Then ' if current date found
With Me 'reference userform
.completeCount.Text = f.Offset(, 1).value
.handledCount.Text = f.Offset(, 2).value
.wipCount.Text = f.Offset(, 3).value
.suspendCount.Text = f.Offset(, 4).value
End With
End If
'your other code to fill listbox
With Worksheets("NamesArchive") ' just a guess...
Me.procNamecombobox.List = Application.Transpose(.Range("A1", .Cells(.Rows.Count, "A").End(xlUp))) 'fill combobox with referenced sheet column A values from rows 1 down to last not empty one
End With
End Sub
BTW, your code could be refactored as follows:
Option Explicit
Private Sub CommandButton1_Click() ' just a guess...
Dim dn As Worksheet: Set dn = Sheets("DailyNumbers")
Dim emptyRow As Long
Dim foundRng As Range
With Me
With .procNamecombobox
If .ListIndex = -1 Then
MsgBox "Please select your name"
Exit Sub
End If
emptyRow = dn.Cells(dn.Rows.Count, "B").End(xlUp).Row + 1
Set foundRng = dn.Range("A1:A" & emptyRow).Find(.value) 'find Combobox value in Column A
If foundRng Is Nothing Then 'if no entry with input name
dn.Range("A" & emptyRow).value = .value 'fill column A first empty with input name
Else 'otherwise
emptyRow = foundRng.Row 'set found cell row index as the one to write in
End If
End With
Intersect(dn.Range("B:F"), dn.Rows(emptyRow)).value = Array(.currentDate.Text, .completeCount.Text, .handledCount.Text, .wipCount.Text, .suspendCount.Text) 'fill columns B to F proper row with textboxes values
End With
End Sub
To help get you started:
A)
Determine if there is a cell in column B with the current date. If so, locate it and use the .Row property to save the row number to a variable.
(There are a couple of range functions (.Find, .Search) that you can use to locate a cell with a particular value. For date's, this link has some helpful information.)
A.5) From the above link, if the dates are in Excel as serial dates -- not text -- then you can use
Set FoundCell = Range("A1:A100").Find _
(what:=Date,lookin:=xlFormulas)
to find the current date in column A from rows 1 to 100. VBA has a function Date() which returns the current day's date. Now() returns the current date and time, while Time() returns the current time.
B)
Set the .text values of the Text/Combo boxes to the values of the cells
(These can be located with a concatenation of the correct column with the saved row variable from earlier. Similar to how you located the cells to save the values initially)
If you're stuck on how to do a particular step or process, and can't find an existing Q&A with information, you can ask for elaboration.
I'm trying to build a new VBA function for Excel. I've got a book of sheets with a front page that always loads first, on this page I've got a combo box that lists all the other sheets in the book and a nice extract button that will pull out the chosen sheet to a new book. (Thanks to those here who helped with that). Now I need a new function that will use the same combo box, but instead only extract a small subset of the chosen sheet.
Unfortunately, that subset isn't on the same rows for every sheet, nor is the number of rows the same (so one sheet, the subset might be 10 rows, on another it might be 12, on another it might be 20, etc etc etc).
On the plus side, there are merged rows (from column A to G) at the start and end of each subset - with specific text, which could be used to search for.
After some back and forth, I've got a better bit of code that I think is almost working:
Sub ZCPS_Extract()
Dim StartRow
Dim EndRow
Dim Zws As Worksheet
Dim wbkOriginal As Workbook
Set wbkOriginal = ActiveWorkbook
StartRow = 1
EndRow = 1
'sets site details into the header of the ZCPS checksheet
Worksheets(Sheet1.CmbSheet.Value).Range("B3").Value = Worksheets("front page").Range("E6")
Worksheets(Sheet1.CmbSheet.Value).Range("D3").Value = Worksheets("front page").Range("N6")
Worksheets(Sheet1.CmbSheet.Value).Range("F3").Value = Worksheets("front page").Range("K6")
Set Zws = Sheets(Sheet1.CmbSheet.Value)
'selects ZCPS block from select estate sheet
StartRow = (Zws.Cells.Find("**** ZCPS Installation").Row) + 1
EndRow = (Zws.Cells.Find("**** Aztec Hotfixes").Row) - 1
'copy above block and paste into Z-MISC starting at row 5
Worksheets(Sheet1.CmbSheet.Value).Range(Cells(StartRow, 1), Cells(EndRow, 7)).Copy Worksheets("Z-MISC").Range("A5")
With ActiveWorkbook.Sheets("Z-MISC")
.Copy
ActiveWorkbook.SaveAs _
"C:\temp\" _
& ActiveWorkbook.Sheets("Z-MISC").Cells(3, 2).Text _
& " ZCPS CheckSheet " _
& Format(Now(), "DD-MM-YY") _
& ".xlsm", _
xlOpenXMLWorkbookMacroEnabled, , , , False
End With
'code to close the original workbook to prevent accidental changes etc
Application.DisplayAlerts = False
wbkOriginal.Close
Application.DisplayAlerts = True
End Sub
It's error on the line for copying, I'm getting a runtime error of "Application-defined or object-defined error" which to my limited knowledge isn't helping me. Any assistance/pointers/suggestions are welcomed.
Sub ismerged()
Dim start As Integer, finish As Integer
For i = 1 To Range("A655").End(3).Row + 1
If Cells(i, "A").MergeCells = True Then
start = i
Exit For
End If
Next
For i = start To Range("A655").End(3).Row + 1
If Cells(i, "A").MergeCells = True Then
finish = i
End If
Next
MsgBox start
MsgBox finish
End Sub
Then I guess you can select your data as you wish.
I'm not sure about the way you reference your sheet. I will assume 'comboboxvalue' contains the name or the number of the sheet you are selecting. Your code should be something like the following.
Sub Z_Extract()
Dim StartRow
Dim EndRow
Dim ws As Worksheet
Set ws = Sheets(comboboxvalue)
StartRow = ws.Cells.Find("**** ZC").Row
EndRow = ws.Cells.Find("****").Row
'Im assuming you have values up to column G
ws.Range(ws.Cells(StartRow, 1), Cells(EndRow, 7)).Copy
'Now that you have the correct Range selected you can copy it to your new workbook
'SelectedRange.Copy Etc.....
'Cleanup
Set ws = Nothing
End Sub
Got it working.
Set Zws = Sheets(Sheet1.CmbSheet.Value)
'selects ZCPS block from selected estate sheet
StartRow = (Zws.Cells.Find("**** ZCPS Installation").Row)
EndRow = (Zws.Cells.Find("**** Aztec Hotfixes").Row) - 1
'copy above block and paste into Z-MISC starting at row 10
Sheets(Sheet1.CmbSheet.Value).Activate
ActiveSheet.Range(Cells(StartRow, 1), Cells(EndRow, 7)).Select
Selection.Copy
Sheets("Z-MISC").Select
Range("A10").Select
ActiveSheet.Paste
I've seen how to say "Is cell x in range y" but since I'm using VLookup I'm not sure how to reconcile the two.
Basically, the code below does a lookup on a table that contains tips and then displays them in a specified cell. It works great. What I would like to do is specify an entire range of cells in the lookup table, then if the user selects any cell within that range the tip is displayed. As it stands, if I have a large area of say 10 cells I have to create 10 duplicate entries in the lookup table (one for each cell).
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim cellTitle As Range
Set cellTitle = Range("J2")
Dim cellTip As Range
Set cellTip = Range("J3")
If Target.Address = "$J$3:$K$5" Or Target.Address = "$J$2:$K$2" Or Target.Address = "$K$1" Then
'leave existing content in case user wants to copy tip
Else
Range("K1").Value = Target.Address
Title = Application.VLookup(Target.Address, Sheets("Settings").Range("TipsDashboard"), 2, False)
If Not IsError(Title) Then
Tip = Application.VLookup(Target.Address, Sheets("Settings").Range("TipsDashboard"), 3, False)
cellTitle.Value = Title
cellTip.Value = Tip
Else
cellTitle.Value = "Tips & Instructions"
cellTip.Value = "Try selecting various fields to get dynamic tips or instructions in this space."
End If
End If
End Sub
Here is a sample of my lookup table:
You'll notice there are ranges here, but they are merged cells.
edited: made so that it's possible to associate different cells in active sheet to the same range value in "cell" column of" Settings" sheet
Option Explicit
Private Sub Worksheet_SelectionChange(ByVal target As Range)
Dim cellTitle As Range, cellTip As Range, found As Range
Set cellTitle = Range("J2")
Set cellTip = Range("J3")
If target.address = "$J$3:$K$5" Or target.address = "$J$2:$K$2" Or target.address = "$K$1" Then
'leave existing content in case user wants to copy tip
Else
Range("K1").Value = target.address
Set found = GetCell(target, Sheets("Settings").Range("TipsDashboard").Columns(1))
If Not found Is Nothing Then
cellTitle.Value = found.Offset(, 1)
cellTip.Value = found.Offset(, 2)
Else
cellTitle.Value = "Tips & Instructions"
cellTip.Value = "Try selecting various fields to get dynamic tips or instructions in this space."
End If
End If
End Sub
Function GetCell(target As Range, sourceRng As Range) As Range
Dim cell As Range, cell2 As Range
With target
For Each cell In sourceRng.SpecialCells(xlCellTypeConstants, xlTextValues)
Set cell2 = GetRangeFromAddress(.Parent, cell.Value)
If Not cell2 Is Nothing Then
If Not Intersect(.cells, cell2) Is Nothing Then
Set GetCell = cell
Exit Function
End If
End If
Next cell
End With
End Function
Function GetRangeFromAddress(sht As Worksheet, address As String) As Range
On Error Resume Next
Set GetRangeFromAddress = sht.Range(address)
On Error GoTo 0
End Function
I'm trying to ensure that data entered into the named range of an Excel spreadsheet is valid. To do this, I've defined a static validation list for column "A" in the range, and enabled the dropdown list for that column. Based on the option selected by the user, I add a validation object in column "B" at runtime, having a list of entries constrained by the entry in column "A". Based on the entries in columns A and B, the cell in column "C" is automatically populated.
This works fine until spreadsheet protection is enabled. At that point, attempting to select an option from the droplist in column "B" generates the following error:
"The cell or chart that you are trying to change is protected and therefore read-only. ... "
However
All cells in the range in question were unlocked prior to adding
worksheet protection.
The code explicitly removes protection prior to updating the
validation object in column "B", then replaces it once the validation
object has been added.
When a list item is selected from the droplist in column "B", the
error message fires immediately before any worksheet events occur,
making it impossible to trap or debug the error.
I have code in both the spreadsheet and in a separate code module, both or which are included below. Any ideas would be greatly appreciated
Here's the code in the Worksheet_Change() event:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim strNm As String
' there will be multiple named ranges eventually. We need to be able to distinguish
' among the various ranges so that our code executes only against the data we expect
' to manipulate - not random cells
If Not Intersect(ActiveCell, ActiveWorkbook.Names("DBAddRange").RefersToRange) Is Nothing Then
Dim rng As Range
Set rng = ActiveWorkbook.Names("DBAddRange").RefersToRange
If Target.Column = 1 Then
If FLAG_CHANGE_IN_PROGRESS = True Then Exit Sub
FLAG_CHANGE_IN_PROGRESS = True
Dim VldnList As String
VldnList = getVldtnList(Target.Value)
unlockSS ActiveSheet
Range("B" & Target.row).Clear
Range("B" & Target.row).Select
With Range("B" & Target.row).Validation
.Delete
.Add Type:=xlValidateList, Operator:=xlValidateList, Formula1:=VldnList
.IgnoreBlank = False
.InCellDropdown = True
End With
lockSS ActiveSheet
Range("B" & Target.row).Select
FLAG_CHANGE_IN_PROGRESS = False
ElseIf Target.Column = 2 Then
If FLAG_CHANGE_IN_PROGRESS = True Then Exit Sub
FLAG_CHANGE_IN_PROGRESS = True
unlockSS ActiveSheet
Dim dbHost As Variant
Dim hNmRng As Range
Set hNmRng = ActiveWorkbook.Names("valid_lookups").RefersToRange
dbHost = Application.VLookup(Target.Value, hNmRng, 2, False)
Range("C" & Target.row).Value = dbHost
lockSS ActiveSheet
FLAG_CHANGE_IN_PROGRESS = False
End If
End If
If Not Intersect(ActiveCell, ActiveWorkbook.Names("HostAddRange").RefersToRange) Is Nothing Then
End If
End Sub
Code in the external module:
Sub lockSS(ByVal sheet As Sheet1)
sheet.Protect Password:=[NOT SHOWN], UserInterfaceOnly:=True, DrawingObjects:=False
Application.EnableEvents = True
End Sub
Function getVldtnList(ByVal dbName As String)
Dim vrtmatchRow As Variant
Dim rng As Range
If dbName = "" Then
getVldtnList = ""
Exit Function
End If
' this is a pre-defined range having entries for:
' DB Name - Column 1
' DB CI ID - Column 2
' DB Host - Column 3
Set rng = ActiveWorkbook.Names("valid_db_nms").RefersToRange
' find the value of the first row in the range that matches the value
' of the dbName parm. NOTE: the final 0 parm tells the match function
' to find an exact match.
vrtmatchRow = Application.Match(dbName, rng, 0)
If IsError(vrtmatchRow) Then
' NOTE: we should NEVER get here due to the way cell validation is set up.
MsgBox "The value entered was not found in the list of valid database values. See xxx for help", vbRetryCancel, "Invalid Entry"
Else
Dim row As Long
Dim strListVals As String
Set rng = ActiveWorkbook.Names("valid_db_info").RefersToRange
row = vrtmatchRow
Do
If Len(strListVals) > 0 Then strListVals = strListVals + ","
strListVals = strListVals + rng.Cells(row, 2).Value
row = row + 1
Loop While (rng.Cells(row, 1).Value = dbName)
End If
getVldtnList = strListVals
End Function
Sub unlockSS(ByVal sheet As Sheet1)
sheet.Unprotect Password:=[NOT SHOWN]
Application.EnableEvents = False
End Sub
Clearing a range will also reset the "locked" checkbox, so you need to reset that each time
Range("B" & Target.row).Clear