I need to open a dialog box and select a workbook. Then copy the data placed in that workbook (which has only 1 sheet with same name all the time).
I want to do the process for many workbooks by using a loop for vbyesno.
This is the only part which is not working because I want to paste data under Range("a14"), then loop and then paste under the data pasted in a14.
Below is the macro which is being called from another macro.
Sub prompt()
Application.DisplayAlerts = False
Dim Target_Workbook As Workbook
Dim Source_Workbook As Workbook
Dim Target_Path As Range
d = MsgBox("Add record?", vbYesNoCancel + vbInformation)
If d = vbNo Then
ActiveSheet.Range("a13").value = "No data Found"
ActiveSheet.Range("a13").Font.Bold = True
ThisWorkbook.Save
ElseIf d = vbCancel Then
Sheets("MPSA").Delete
ThisWorkbook.Save
ElseIf d = vbYes Then
Sheets("MPSA").Range("a14").value = "NAME"
Sheets("MPSA").Range("b14").value = "NUMBER"
Sheets("MPSA").Range("c14").value = "AGR NUMBER"
Sheets("MPSA").Range("d14").value = "ENTITY NAME"
Sheets("MPSA").Range("e14").value = "GROUP"
Sheets("MPSA").Range("f14").value = "DELIVERABLE"
Sheets("MPSA").Range("g14").value = "DELIVERAB"
Sheets("MPSA").Range("h14").value = "IS COMPON"
Sheets("MPSA").Range("i14").value = "PACKAGE"
Sheets("MPSA").Range("j14").value = "ORDERS"
Sheets("MPSA").Range("k14").value = "LICNTITY"
Sheets("MPSA").Range("l14").value = "QUANTITY"
Sheets("MPSA").Range("m14").value = "ORDERANUMBER"
Sheets("MPSA").Range("n14").value = "ORDERAM NAME"
Sheets("MPSA").Range("o14").value = "PAC NUMBER"
Sheets("MPSA").Range("p14").value = "PACKAGAME"
Sheets("MPSA").Range("q14").value = "ITTION"
Sheets("MPSA").Range("r14").value = "LICENSE TYPE"
Sheets("MPSA").Range("s14").value = "ITEM VERSION"
Sheets("MPSA").Range("t14").value = "REAGE"
Sheets("MPSA").Range("u14").value = "CLIIT"
Sheets("MPSA").Range("v14").value = "LICEAME"
Sheets("MPSA").Range("w14").value = "ASSATE"
Sheets("MPSA").Range("x14").value = "ASSTE"
Sheets("MPSA").Range("y14").value = "ENTITTUS"
Sheets("MPSA").Range("z14").value = "ASSGORY"
Sheets("MPSA").Range("aa14").value = "PURCHAYPE"
Sheets("MPSA").Range("ab14").value = "BILLTHOD"
Sheets("MPSA").Range("ac14").value = "SALETER"
Cells.Columns.AutoFit
Target_Path = Application.GetOpenFilename
Set Target_Workbook = Workbooks.Open(Target_Path)
Set Source_Workbook = ThisWorkbook
Target_Data = Target_Workbook.Sheets(1).Range("A1").CurrentRegion.Copy
Target_Workbook.Close
Source_Workbook.Sheets("MPSA").Range("a14").End(xlDown).Offset(1, 0).PasteSpecial = Target_Data
ActiveCell.EntireRow.Delete
ThisWorkbook.Save
ThisWorkbook.Save
End If
End Sub
I was going to propose a mechanism to achieve the loop, supposing that your current code is somewhere near what you want to achieve. But I found many mistakes so I had to refactor it, hopefully it will get you a step further.
The following code will continue looping until user presses Cancel in the file dialog box:
Sub prompt()
Dim d As VbMsgBoxResult: d = MsgBox("Add record?", vbYesNoCancel + vbInformation)
If d = vbNo Then
Sheets("MPSA").Range("a13").value = "No data Found"
Sheets("MPSA").Range("a13").Font.Bold = True
ThisWorkbook.Save
Exit Sub
End If
If d = vbCancel Then
Sheets("MPSA").Delete
ThisWorkbook.Save
Exit Sub
End If
On Error GoTo Cleanup
Application.DisplayAlerts = False: Application.EnableEvents = False: Application.ScreenUpdating = False
Sheets("MPSA").Range("a14:ac14").value = Array( _
"NAME", "NUMBER", "AGR NUMBER", "ENTITY NAME", "GROUP", "DELIVERABLE", "DELIVERAB", "IS COMPON", _
"PACKAGE", "ORDERS", "LICNTITY", "QUANTITY", "ORDERANUMBER", "ORDERAM NAME", "PAC NUMBER", "PACKAGAME", _
"ITTION", "LICENSE TYPE", "ITEM VERSION", "REAGE", "CLIIT", "LICEAME", "ASSATE", "ASSTE", _
"ENTITTUS", "ASSGORY", "PURCHAYPE", "BILLTHOD", "SALETER")
Sheets("MPSA").Columns.AutoFit
Dim Target_Path: Target_Path = Application.GetOpenFilename
Do While Target_Path <> False ' <-- loop until user cancels
Dim Target_Workbook As Workbook: Set Target_Workbook = Workbooks.Open(Target_Path)
Target_Workbook.Sheets(1).Range("A1").CurrentRegion.Copy _
ThisWorkbook.Sheets("MPSA").Range("a1000000").End(xlUp).Offset(1)
Target_Workbook.Close False
ActiveCell.EntireRow.Delete
ThisWorkbook.Save
Target_Path = Application.GetOpenFilename
Loop
Cleanup:
If Err.Number <> 0 Then MsgBox "Something went wrong: " & vbCrLf & Err.Description
Application.DisplayAlerts = True: Application.EnableEvents = True: Application.ScreenUpdating = True
End Sub
Related
i currently have a problem with a simple login form in excel (VBA), when having an error, continuing and having another error it still gives me two more MsgBoxes with errors but with the "Unload Me" and "Goto Ende" it should close itself completely.
Any guesses why this isn't working? I know this is very basic and probably very redundant, but it should still work.
Public Name As Variant
Public Password As Variant
Private Sub Btn_Register_Cancel_Click()
Unload Me
End Sub
Private Sub Btn_Register_Register_Click()
Start:
Dim Error As Integer
Error = 0
Name = Tbx_Register_Name.Value
Password = Tbx_Register_Password.Value
'Check for Name, Password, Password2 if empty
If Tbx_Register_Name.Value = "" Then
Error = MsgBox("Please enter a username.", _
vbRetryCancel, "Error")
If Error = 2 Then
Unload Me
GoTo Ende
Else
Application.ScreenUpdating = False
Register.Hide
Register.Show
Application.ScreenUpdating = True
GoTo Start
End If
ElseIf Tbx_Register_Password.Value = "" Then
Error = MsgBox("Please enter a password.", _
vbRetryCancel, "Error")
If Error = 2 Then
Unload Me
GoTo Ende
Else
Application.ScreenUpdating = False
Register.Hide
Register.Show
Application.ScreenUpdating = True
GoTo Start
End If
ElseIf Tbx_Register_Password2.Value = "" Then
Error = MsgBox("This field cannot be empty.", _
vbRetryCancel, "Error")
If Error = 2 Then
Unload Me
GoTo Ende
Else
Application.ScreenUpdating = False
Register.Hide
Register.Show
Application.ScreenUpdating = True
GoTo Start
End If
End If
With Workbooks("General Makro.xlsx").Worksheets("User")
'Check for Username match in registration list
For i = 1 To 100
If .Cells(i, 1).Value = Name Then
Error = MsgBox("This username is already taken.", _
vbRetryCancel, "Error")
If Error = 2 Then
Unload Me
i = 100
GoTo Ende
Else
Application.ScreenUpdating = False
Register.Hide
Register.Show
Application.ScreenUpdating = True
GoTo Start
End If
End If
Next i
End With
'Check for the passwords to match
If Tbx_Register_Password.Value = Tbx_Register_Password2.Value Then
With Workbooks("General Makro.xlsx").Worksheets("User")
For i = 1 To 100
If .Cells(i, 1) = "" Then
.Cells(i, 1).Value = Name
.Cells(i, 2).Value = Password
Tbx_Register_Password.Value = ""
Tbx_Register_Password2.Value = ""
Application.ScreenUpdating = False
Register.Hide
Login.Show
Tbx_Login_Name.Value = .Cells(i, 1).Value
Tbx_Login_Password.Value = .Cells(i, 2).Value
Application.ScreenUpdating = True
i = 100
GoTo Ende
End If
Next i
End With
Else
Error = MsgBox("The passwords have to match!", vbRetryCancel, "Error")
If Error = 2 Then
Unload Me
GoTo Ende
Else
Application.ScreenUpdating = False
Register.Hide
Register.Show
Application.ScreenUpdating = True
GoTo Start
End If
End If
Ende:
End Sub
Edit: I Actually Tried to do the 2nd UserForm for the login, and i happen to get the same problem there. Everything works just fine, until i close the whole program, then the error-message appears again. Am i unloading the userform incorrect? Maby the login userform says open and continues when everything is getting closed.
Edit 2: I could just turn off alerts but that would be an ugly solution and definitely nothing i want to implement on every close button in the program.
You can verify blank values in textboxes with this:
If TextBox.Text = "" Then
MsgBox "Is blank!"
Unload Me
GoTo Ende
End If
'Your code
Ende: Exit Sub
To verify the username and password in a database, you can do this:
Dim sh As Worksheet
Dim LastRow As Long
Dim UserRange As Range
Dim UserMatch As Range
Set sh = ThisWorkbook.Sheets("database")
LastRow = sh.Range("A" & Rows.Count).End(xlUp).Row
Set UserRange = sh.Range("A1:A" & LastRow)
Set UserMatch = UserRange.Find(What:=UserTextBox.Text, LookIn:=xlValues)
If Not UserMatch Is Nothing Then
MsgBox "User exists!"
If PwdTextBox.Text = UserMatch.Offset(0, 1) Then
MsgBox "Pwd matched!"
'do something
Else
MsgBox "Wrong password!"
'do something
End If
Else
MsgBox "User dont exists!"
'do something
End If
This will work if in the database the usernames are in column A and the passwords in column B.
I am running two VBA formulas.
The first hides all cells with empty information the first column.
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim c As Range
On Error Resume Next
Application.ScreenUpdating = False
For Each c In Range("A3:A49")
If c.Value = vbNullString Then
c.EntireRow.Hidden = True
End If
Next c
For Each c In Range("A3:A47")
If c.Value <> vbNullString Then
c.EntireRow.Hidden = False
End If
Next c
Application.ScreenUpdating = True
End Sub
The second Formula strings data together and placeses this information in the next cell that is empty (aka the first hidden cell) when the button is clicked.
Option Explicit
Dim iwsh As Worksheet
Dim owsh As Worksheet
Dim output As String
Dim i As Integer
Sub Copy()
Set iwsh = Worksheets("Budget")
Set owsh = Worksheets("Release Burnup")
i = 3
While owsh.Cells(i, 1) <> ""
i = i + 1
Wend
output = "R" & iwsh.Cells(13, 2).Value & "-S" & iwsh.Cells(14, 2).Value
owsh.Cells(i, 1) = output
ActiveSheet.EnableCalculation = False
ActiveSheet.EnableCalculation = True
End Sub
Previously, this has been causing no problem... Something has happened that is causing the workbook to crash anytime I try to delete information out of one of the cells with the new data.
PS: This is the list of my other formulas. maybe there is something in these that is interacting with the formentioned code?
Private Sub NewMemberBut_Click()
'causes userform to appear
NewMember.Show
'reformats button because button kept changing size and font
NewMemberBut.AutoSize = False
NewMemberBut.AutoSize = True
NewMemberBut.Height = 40.25
NewMemberBut.Left = 303.75
NewMemberBut.Width = 150
End Sub
'Similar code to the problematic code in question, but this one works fine
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim c As Range
On Error Resume Next
Application.ScreenUpdating = False
For Each c In Range("A3:A35,A41:A80")
If c.Value = vbNullString Then
c.EntireRow.Hidden = True
End If
Next c
For Each c In Range("A3:A35,A41:A80")
If c.Value <> vbNullString Then
c.EntireRow.Hidden = False
End If
Next c
Application.ScreenUpdating = True
End Sub
'Code for UserForm
Option Explicit
Dim mName As String
Dim cName As String
Dim mRole As String
Dim cRole As String
Dim i As Integer
Dim x As Integer
Dim Perc As Integer
Dim Vac As Integer
Dim Prj As Worksheet
Dim Bud As Worksheet
Private Sub NewMember_Initialize()
txtName.Value = ""
cboRoleList.Clear
Scrum.Value = False
txtPercent.Value = ""
txtVacation.Value = ""
txtName.SetFocus
End Sub
Private Sub AddMember_Click()
If Me.txtName.Value = "" Then
MsgBox "Please enter a Member name.", vbExclamation, "New Member"
Me.txtName.SetFocus
Exit Sub
End If
If Me.cboRoleList = "Other" And Me.txtCustomRole = "" Then
MsgBox "Please provide a role name.", vbExclamation, "Other Role"
Exit Sub
End If
If Me.cboRoleList.Value = "" Then
MsgBox "Please select a Role.", vbExclamation, "Member Role"
Me.cboRoleList.SetFocus
Exit Sub
End If
If Me.cboRoleList <> "Other" And Me.txtPercent = "" Then
MsgBox "Please select a valid percentage to be applied to this sprint.", vbExclamation, "Sprint Percent"
Me.txtPercent.SetFocus
Exit Sub
End If
If Me.txtPercent.Value > 100 And Me.txtPercent <> "" Then
MsgBox "Please select a valid percentage to be applied to this sprint.", vbExclamation, "Sprint Percent"
Me.txtPercent.SetFocus
Exit Sub
End If
If Me.txtVacation.Value = "" Then
Me.txtVacation.Value = 0
End If
Dim i As Long
Set Prj = Worksheets("Project Team")
Set Bud = Worksheets("Budget")
Prj.Activate
i = 5
x = 1
If Me.cboRoleList.Value = "Other" Then
i = 46
End If
While Prj.Cells(i, 1) <> ""
i = i + 1
Wend
If cboRoleList = "Other" Then
Cells(i, x).Value = txtCustomRole.Value
End If
If cboRoleList <> "Other" Then
Cells(i, x).Value = cboRoleList.Value
End If
x = x + 1
Cells(i, x).Value = txtName.Value
x = x + 1
If Me.cboRoleList.Value <> "Other" Then
Cells(i, x).Value = txtPercent.Value
End If
Unload Me
End Sub
Private Sub CloseBut_Click()
Unload Me
End Sub
Change the event driven Worksheet_SelectionChange to Worksheet_Change and isolate further by only processing when something changes in A3:A49.
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("A3:A49")) Is Nothing Then
On Error GoTo safe_exit
Application.EnableEvents = False
Application.ScreenUpdating = False
Dim c As Range
For Each c In Intersect(Target, Range("A3:A49"))
c.EntireRow.Hidden = CBool(c.Value = vbNullString)
Next c
End If
safe_exit:
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
Caveat: A Worksheet_Change is not triggered on the change in a cell from the cell's formula. Only by typing, deleting or dragging a cell's contents. Adding or removing a formula will trigger it but not when a formula's result changes from another value somewhere in the workbook changing. This should not affect you as no formula can return vbNullString but it is worth mentioning for others.
U would like to know how i can retrieve data from an excel sheet and update it in a userform.
on the picture you can see what the userform looks like.
What i would like to do is make another userform that can search for a specific reference in the sheet and update some cells of that specific row.
This is the code I have now to insert data into the sheet.
Private Sub cmdClear_Click()
' Clear the form
For Each ctl In Me.Controls
If TypeName(ctl) = "TextBox" Or TypeName(ctl) = "ComboBox" Then
ctl.Value = ""
ElseIf TypeName(ctl) = "CheckBox" Then
ctl.Value = False
End If
Next ctl
End Sub
Private Sub cmdSend_Click()
Dim RowCount As Long
Dim ctl As Control
' Check user input
If Me.combTechnieker.Value = "" Then
MsgBox "Dag vreemdeling! Welke van de 4 Mongolen ben je?", vbExclamation, "RMA invoer"
Me.combTechnieker.SetFocus
Exit Sub
End If
If Me.txtPcwRef.Value = "" Then
MsgBox "Vul onze referentie in!", vbExclamation, "RMA invoer"
Me.txtPcwRef.SetFocus
Exit Sub
End If
If Me.txtKlant.Value = "" Then
MsgBox "Vul de naam van de klant in!", vbExclamation, "RMA invoer"
Me.txtKlant.SetFocus
Exit Sub
End If
If Me.txtMerk.Value = "" Then
MsgBox "Vul het merk in!", vbExclamation, "RMA invoer"
Me.txtMerk.SetFocus
Exit Sub
End If
If Me.txtMerkRef.Value = "" Then
MsgBox "Vul de referentie van de fabrikant in!", vbExclamation, "RMA invoer"
Me.txtMerkRef.SetFocus
Exit Sub
End If
If Me.txtProduct.Value = "" Then
MsgBox "Vul het product in!", vbExclamation, "RMA invoer"
Me.txtProduct.SetFocus
Exit Sub
End If
If Me.txtSerienummer.Value = "" Then
MsgBox "Vul het serienummer in!", vbExclamation, "RMA invoer"
Me.txtSerienummer.SetFocus
Exit Sub
End If
If Me.txtProbleem.Value = "" Then
MsgBox "Vul de probleem omschrijving in!", vbExclamation, "RMA invoer"
Me.txtProbleem.SetFocus
Exit Sub
End If
If Me.txtOnderdelen.Value = "" Then
MsgBox "Bent u zeker dat er geen onderdelen achterblijven. Indien ja. Vul N/A in", vbExclamation, "RMA invoer"
Me.txtOnderdelen.SetFocus
Exit Sub
End If
' Write data to worksheet
RowCount = Worksheets("RMA 2016").Range("A1").CurrentRegion.Rows.Count
With Worksheets("RMA 2016").Range("A1")
.Offset(RowCount, 0).Value = Format(Now, "dd/mm/yyyy hh:nn:ss")
.Offset(RowCount, 1).Value = "Open"
.Offset(RowCount, 3).Value = Me.txtPcwRef.Value
.Offset(RowCount, 4).Value = Me.txtKlant.Value
.Offset(RowCount, 5).Value = Me.txtMerk.Value
.Offset(RowCount, 6).Value = Me.txtMerkRef.Value
.Offset(RowCount, 7).Value = Me.txtProduct.Value
.Offset(RowCount, 8).Value = Me.txtSerienummer.Value
.Offset(RowCount, 9).Value = Me.txtOnderdelen.Value
.Offset(RowCount, 10).Value = Me.txtProbleem.Value
.Offset(RowCount, 13).Value = Me.combTechnieker.Value
If Me.chkGarantie.Value = True Then
.Offset(RowCount, 2).Value = "Ja"
Else
.Offset(RowCount, 2).Value = "Nee"
End If
End With
' Clear the form
For Each ctl In Me.Controls
If TypeName(ctl) = "TextBox" Or TypeName(ctl) = "ComboBox" Then
ctl.Value = ""
ElseIf TypeName(ctl) = "CheckBox" Then
ctl.Value = False
End If
Next ctl
End Sub
Private Sub UserForm_Click()
End Sub
I have created a small example to showcase how the general mechanics of loading, saving and deleting a record can work together with the form. When you try to save a record with non-existing ID, it will append a new record to the table. This should be very close to what you are asking and shows you how to shuffle data between a user form and a worksheet.
Private Sub cmdLoad_Click()
' check if provided product ID is not empty
If Len(Trim(Me.txtId)) = 0 Then
MsgBox "Enter product ID to load the record."
Exit Sub
End If
' try to retrieve the product by ID
Dim rngIdList As Range, rngId As Range
Set rngIdList = ActiveSheet.Range([a2], [a2].End(xlDown))
Set rngId = rngIdList.Find(Me.txtId, LookIn:=xlValues)
If rngId Is Nothing Then
' product ID is not found
MsgBox "Product ID " & Me.txtId & " doesn't exist."
Exit Sub
Else
' product ID is found -- fill out the form
Me.txtId = rngId.Offset(0, 0)
Me.txtName = rngId.Offset(0, 1)
Me.txtNote = rngId.Offset(0, 2)
End If
End Sub
Private Sub cmdSave_Click()
' check if provided product ID is not empty
If Len(Trim(Me.txtId)) = 0 Then
MsgBox "Enter product ID to load the record."
Exit Sub
End If
' try to retrieve the product by ID
Dim rngIdList As Range, rngId As Range
Set rngIdList = ActiveSheet.Range([a2], [a2].End(xlDown))
Set rngId = rngIdList.Find(Me.txtId, LookIn:=xlValues)
If rngId Is Nothing Then
' if product ID is not found, append new one to the end of the table
With rngIdList
Set rngId = .Offset(.Rows.Count, 0).Resize(1, 1)
End With
End If
' update excel record
rngId.Offset(0, 0) = Me.txtId
rngId.Offset(0, 1) = Me.txtName
rngId.Offset(0, 2) = Me.txtNote
End Sub
Private Sub cmdDelete_Click()
' check if provided product ID is not empty
If Len(Trim(Me.txtId)) = 0 Then
MsgBox "Enter product ID to delete the record."
Exit Sub
End If
' try to retrieve the product by ID
Dim rngIdList As Range, rngId As Range
Set rngIdList = ActiveSheet.Range([a2], [a2].End(xlDown))
Set rngId = rngIdList.Find(Me.txtId, LookIn:=xlValues)
If rngId Is Nothing Then
' product ID is not found -- nothing to delete
MsgBox "Product ID " & Me.txtId & " doesn't exist."
Exit Sub
Else
' product ID is found -- delete the entire line
rngId.EntireRow.Delete
End If
End Sub
Here is a link that will explain how to do this.
http://www.onlinepclearning.com/edit-and-delete-from-a-userform/
You essentially need to record a macro using an advanced filter that filters your data based on whatever criteria you want. That data can then be used to feed a listbox in your userform using a dynamic name range where your filtered data is copied too. You can then write some code that allows it feed empty text boxes in the userform when double clicked. Then using a recorded macro that utilizes the 'find' function of excel it can find the updated entry (if it has a unique ID) and replace the old values with the new ones.
The link provided will walk through this step by step. You will just need to modify to fit in your workbook.
Hope this helps!
Example of a project I did:
'this is my recorded filter
Sub FilterData()
'
' FilterData Macro
'
'
Sheets("Propert Data").Range("A6:M80").AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=Range("Sheet2!Criteria"), CopyToRange:=Range( _
"Sheet2!Extract"), Unique:=False
End Sub
'This feeds the listbox
Dim ws As Worksheet
'Set Worksheet Variable
Set ws = Sheet2
'Run Filter
FilterLoans 'this is a recorded macro
'Add named range to rowsource
If ws.Range("A5").Value = "" Then
Me.loanlist.RowSource = ""
Else
Me.loanlist.RowSource = "FilterLoans" 'this is a dynamic name range
End If
'This feeds the empty cells
Private Sub loanlist_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
Dim i As Integer
On Error Resume Next
i = Me.loanlist.ListIndex
Me.edloannametxt.Value = Me.loanlist.Column(0, i)
Me.edpropnametxt.Value = Me.loanlist.Column(1, i)
Me.edloantypecbx.Value = Me.loanlist.Column(2, i)
Me.edbalancetxt.Value = Me.loanlist.Column(3, i)
Me.edbalancetxt.Value = Format(Val(edbalancetxt.Value), "$#,###")
Me.edpmttxt.Value = Me.loanlist.Column(4, i)
Me.edpmttxt.Value = Format(Val(edpmttxt.Value), "$#,###")
Me.edannualtxt.Value = Me.loanlist.Column(5, i)
Me.edannualtxt.Value = Format(Val(edannualtxt.Value), "$#,###")
Me.edratetxt.Value = Me.loanlist.Column(6, i)
Me.edratetxt.Value = Format(Val(edratetxt.Value), "Percent")
Me.edamtxt.Value = Me.loanlist.Column(7, i)
Me.edbbtcbx.Value = Me.loanlist.Column(8, i)
Me.uidtxt.Value = Me.loanlist.Column(9, i)
End Sub
'this finds and updates that old data
Private Sub updateloancmd_Click()
Dim findvalue As Range
Dim cNum As Integer
Dim DataSH As Worksheet
Application.ScreenUpdating = False
Set DataSH = Sheet10
Set findvalue = DataSH.Range("K:K"). _
Find(What:=Me.uidtxt.Value, LookIn:=xlValues, LookAt:=xlWhole)
findvalue = uidtxt.Value
If findvalue = "" Then
Exit Sub
Else
findvalue.Offset(0, -1) = edbbtcbx.Value
findvalue.Offset(0, -2) = edamtxt.Value
findvalue.Offset(0, -3) = edratetxt.Value
findvalue.Offset(0, -5) = edpmttxt.Value
findvalue.Offset(0, -6) = edbalancetxt.Value
findvalue.Offset(0, -7) = edloantypecbx.Value
findvalue.Offset(0, -8) = edpropnametxt.Value
findvalue.Offset(0, -9) = edloannametxt.Value
End If
End Sub
I have below code to open sharepoint 2010 document library's specific document based on filename (library has only excelfiles) but I am unable to read the metadata of that file. I tried with Builtin and custom document properties but there is not luck.
Sub OpenSharePointFile(StrSharePointUrl As String, strDocLibrary As String, FileNameWithExt As String)
Application.ScreenUpdating = False
Dim SPWorkbook As Workbook
Dim this As Workbook
Dim sh As Shape
Application.DisplayAlerts = False
Set SPWorkbook = Workbooks.Open(StrSharePointUrl & strDocLibrary & "\" & FileNameWithExt)
Application.DisplayAlerts = True
Set this = ThisWorkbook
If SPWorkbook Is Nothing Then
MsgBox "This product is not available"
Exit Sub
Else
'Copy Metadata
'ThisWorkbook.Sheets(Sht_Input.Name).Range("C3").Value = SPWorkbook.BuiltinDocumentProperties("Title")
'ThisWorkbook.Sheets(Sht_Input.Name).Range("C4").Value = SPWorkbook.BuiltinDocumentProperties("Business Unit")
'ThisWorkbook.Sheets(Sht_Input.Name).Range("C5").Value = SPWorkbook.BuiltinDocumentProperties("ItemNo")
'ThisWorkbook.Sheets(Sht_Input.Name).Range("C6").Value = SPWorkbook.BuiltinDocumentProperties("ECO Type")
'ThisWorkbook.Sheets(Sht_Input.Name).Range("C7").Value = SPWorkbook.BuiltinDocumentProperties("ItemDescription")
'ThisWorkbook.Sheets(Sht_Input.Name).Range("C8").Value = SPWorkbook.BuiltinDocumentProperties("Status")
'ThisWorkbook.Sheets(Sht_Input.Name).Range("C9").Value = SPWorkbook.BuiltinDocumentProperties("CasmasUpdate")
'ThisWorkbook.Sheets(Sht_Input.Name).Range("E3").Value = SPWorkbook.BuiltinDocumentProperties("LabelData")
'ThisWorkbook.Sheets(Sht_Input.Name).Range("E4").Value = SPWorkbook.BuiltinDocumentProperties("SpqWhActive")
'ThisWorkbook.Sheets(Sht_Input.Name).Range("E5").Value = SPWorkbook.BuiltinDocumentProperties("I2of5Label")
'ThisWorkbook.Sheets(Sht_Input.Name).Range("E6").Value = SPWorkbook.BuiltinDocumentProperties("TiXHi")
'ThisWorkbook.Sheets(Sht_Input.Name).Range("E7").Value = SPWorkbook.BuiltinDocumentProperties("SpecSent")
'ThisWorkbook.Sheets(Sht_Input.Name).Range("E8").Value = SPWorkbook.BuiltinDocumentProperties("CasmasToYes")
'ThisWorkbook.Sheets(Sht_Input.Name).Range("E9").Value = SPWorkbook.BuiltinDocumentProperties("EcoOwner")
'Copy ECO Summary:
ThisWorkbook.Sheets(Sht_Input.Name).Range("B12").Value = SPWorkbook.Sheets(Sht_Input.Name).Range("B12").Value
'Copy Ref ID
ThisWorkbook.Sheets(Sht_Input.Name).Range("D14").Value = SPWorkbook.Sheets(Sht_Input.Name).Range("D14").Value
'Copy THIS ITEM
SPWorkbook.Sheets(Sht_Input.Name).Range("C14:C74" & lRow).Copy
ThisWorkbook.Sheets(Sht_Input.Name).Range("C14").PasteSpecial xlPasteValues
'Delete from this workbook if available and Copy Shape if available in Sharepoint
If ThisWorkbook.Sheets(Sht_LCEncodingInfo.Name).Shapes.Count = 2 Then
For Each sh In ThisWorkbook.Sheets(Sht_LCEncodingInfo.Name).Shapes
If sh.Name <> "Picture 1" Then
sh.Delete
End If
Next
End If
If SPWorkbook.Sheets(Sht_LCEncodingInfo.Name).Shapes.Count = 2 Then
For Each sh In SPWorkbook.Sheets(Sht_LCEncodingInfo.Name).Shapes
If sh.Name <> "Picture 1" Then
sh.Height = 150 ' 138.96 '1.93"
sh.Width = 150 ' 228.24 '3.17"
sh.Copy
Application.Goto ThisWorkbook.Sheets(Sht_LCEncodingInfo.Name).Range("F9")
ActiveSheet.Paste
End If
Next
ThisWorkbook.Sheets(Sht_LCEncodingInfo.Name).Range("G2").Select
End If
'Activate Input sheet
ThisWorkbook.Sheets(Sht_Input.Name).Activate
ThisWorkbook.Sheets(Sht_Input.Name).Range("C3").Select
Application.DisplayAlerts = False
SPWorkbook.Close
Application.DisplayAlerts = True
MsgBox "Product Details fetched."
End If
Application.ScreenUpdating = True
End Sub
Try using ActiveWorkbook.ContentTypeProperties("Your column name")
instead of SPWorkbook.BuiltinDocumentProperties("Your column name")
Hi i am trying to program a user form in excel that a user inputs the information and can select the worksheet that they want the information that was entered in to go to that spread sheet.
This is what i have so far.
Dim iRow As Long
Dim sheet As String
sheet = ComboBox1.Value
Worksheets(sheet).Activate
iRow = sheet.Cells.Find(what:="*", seatchOrder:=xlRows, searchdirection:=xlPrevious, LookIn:=xlValues).Row + 1
when i run the user form and select the worksheet in the combo box and hit the command button to run the form i get the error "invalid qualifier"
it highlights sheet.cells
here is the entire code if it helps:
Private Sub ComboBox1_Change()
End Sub
Private Sub CommandButton1_Click()
'get item button
Dim sheet As String
UserForm8.Hide
MsgBox ("Select an item to update")
sheet = ComboBox1.Value
Worksheets(sheet).Activate
Set ProjRng = Application.InputBox(Message, Title, "", 377, 58, , , 8)
ProjSel = ProjRng.Cells.Row
Label1.Enabled = True
Label2.Enabled = True
Label3.Enabled = True
Label4.Enabled = True
Label8.Enabled = True
Label10.Enabled = True
TextBox1.Enabled = True
TextBox2.Enabled = True
TextBox3.Enabled = True
TextBox4.Enabled = True
TextBox8.Enabled = True
TextBox10.Enabled = True
TextBox10.Locked = False
CommandButton1.Enabled = True
ComboBox1.Enabled = True
UserForm8.TextBox1.Value = ActiveSheet.Cells(ProjSel, 1).Value
UserForm8.TextBox2.Value = ActiveSheet.Cells(ProjSel, 2).Value
UserForm8.TextBox3.Value = ActiveSheet.Cells(ProjSel, 3).Value
UserForm8.TextBox4.Value = ActiveSheet.Cells(ProjSel, 4).Value
UserForm8.TextBox8.Value = ActiveSheet.Cells(ProjSel, 8).Value
UserForm8.TextBox11.Value = ActiveSheet.Cells(ProjSel, 6).Value
UserForm8.Show
End Sub
Private Sub CommandButton2_Click()
'Update button to update the remaing quantity amount
Dim iRow As Long
Dim sheet As String
sheet = ComboBox1.Value
Worksheets(sheet).Activate
iRow = sheet.Cells.Find(what:="*", seatchOrder:=xlRows, searchdirection:=xlPrevious, LookIn:=xlValues).Row + 1
With Worksheets("ChemLog")
.Cells(iRow, 6).Value = Me.TextBox12
End With
With sheet
.Cells(iRow, 1).Value = Me.TextBox1.Value
end with
'continue above with columns according to log
End Sub
Private Sub TextBox10_Change()
End Sub
Private Sub TextBox11_Change()
End Sub
Private Sub UserForm_Click()
End Sub
Private Sub UserForm_Initialize()
ComboBox1.AddItem ("Standards")
ComboBox1.AddItem ("Acids,Bases, and Buffers")
ComboBox1.AddItem ("Solvents and Flammables")
End Sub
As well as the spelling error, sheet is a string, so it requires:
Worksheets(sheet).Cells.Find(..
which is the reason for the specific error message you receive.