Good day! I need some help with some codes about combobox.
here's my code:
Dim sh As Worksheet
Set sh = ActiveWorkbook.Sheets("Home")
Dim LR As Long
Dim table2 As ListObject
LR = Sheets("Home").Range("E" & Rows.Count).End(xlUp).Row
Set table2 = sh.ListObjects("Table1356")
Dim lr2 As ListRow
Set lr2 = table2.ListRows.add
With lr2
.Range(2).Value = pos_form.pos_orderno.Value
.Range(3).Value = pos_form.pos_date.Value
.Range(4).Value = pos_cmbx_name.Value
.Range(5).Value = pos_form.pos_category.Value
.Range(6).Value = pos_form.pos_quantity.Value
.Range(7).Value = pos_form.pos_price.Value
.Range(8).Value = pos_form.pos_customer.Value
.Range(9).Value = pos_form.pos_address.Value
.Range(10).Value = pos_form.pos_contact.Value
.Range(11).Value = pos_form.pos_other.Value
If pos_form.pos_cod.Value Then .Range(15).Value = "COD/CASH"
If pos_form.pos_gcash.Value Then .Range(15).Value = "G-CASH"
End With
pos_form.pos_orderno.Value = ""
pos_form.pos_date.Value = ""
pos_form.pos_cmbx_name.Clear
pos_form.pos_category.Value = ""
pos_form.pos_quantity.Value = ""
pos_form.pos_price.Value = ""
pos_form.pos_customer.Value = ""
pos_form.pos_address.Value = ""
pos_form.pos_contact.Value = ""
pos_form.pos_other.Value = ""
pos_form.pos_cod.Value = False
pos_form.pos_gcash.Value = False
Worksheets("Home").Protect "Roshier"
Unload pos_form
Exit Sub
I got a problem with my combobox, ".Range(4).Value = pos_cmbx_name.Value". When I click the add button to transfer its data to the excel sheet with table, in a few second it will be lagged/hanged and automatically restart the excel file. I don't know why and how to fix this.
I removed the code and the files is running smoothly but the 4th column leaving blank.
enter image description here
Please anyone who could help me? Thanks in advance!~
Related
Can anyone please help me to figure out what is wrong with below VBScripting and how should I correct it?
It meant to
Open excel -- works
Refresh all data -- works
Remove external connection -- Dont work
Save as new file without any external connection -- Dont work due to 3rd step otherwise it does
Solution:
Set oExcel = CreateObject("Excel.Application")
oExcel.Application.Visible = True
oExcel.DisplayAlerts = False
oExcel.AskToUpdateLinks = False
oExcel.AlertBeforeOverwriting = False
Set oWorkbook = oExcel.Workbooks.Open("file path.xlsx")
oWorkbook.RefreshAll
Do While oExcel.ActiveWorkbook.Connections.Count > 0
oExcel.ActiveWorkbook.Connections.Item(oExcel.ActiveWorkbook.Connections.Count).Delete
Loop
oExcel.Activeworkbook.SaveAs "NewFileName_"& _
MyDateFormat &".xlsx"
oExcel.Activeworkbook.Close
oExcel.Quit
WScript.Quit
Please, try the next way:
Dim oExcel, oWorkbook
Set oExcel = CreateObject("Excel.Application")
oExcel.Application.Visible = True
oExcel.DisplayAlerts = False
oExcel.AskToUpdateLinks = False
oExcel.AlertBeforeOverwriting = False
Set oWorkbook = oExcel.Workbooks.Open("file path.xlsx")
oWorkbook.RefreshAll
'new approach to also delete the named range from Name Manager
Dim strAddr, N
strAddr = Split(oWorkbook.Connections("connection name").Ranges(1).Address(,,,True), "]")(1)
oWorkbook.Connections("connection name").Delete
For Each N In oWorkbook.Names
If Replace(strAddr, "'", "") = Replace(Mid(N.RefersTo, 2), "'", "") Then
N.Delete
End If
Next
oWorkbook.SaveAs "NewFileName_" & MyDateFormat & ".xlsx"
oWorkbook.Close
oExcel.Quit
I've been doing some VBA stuff lately but i don't know what directions to take.
Someone here helped me with the copy to Word, i've lost the topic but thanks a lot!
Is there a better way to read in the BookMarks and how can i get them to link the right sheet in this line;
MyArray(i)
'needs to go in to;
wb.worksheet(Myarray(i)).range("A1:BA3000")
I've been spending way to many hours on the array part.
Private Sub ranges()
Dim NamedRange As name
Dim nm As name
Dim ws As Worksheet
Dim Lr As Long
Dim Lc As Long
Dim Rng As range
Dim Bm As name
Dim wb As Workbook
Dim Fill As range
Dim wd As Word.Application
Set wd = New Word.Application
Set wb = ThisWorkbook 'Workbooks("C:\Excel")
Set aWs = ActiveSheet
'array with names of the word bookmarks
Dim myArray(38)
myArray(0) = ("Tappunten")
myArray(1) = ("test1")
myArray(2) = ("Groslijst")
myArray(3) = ("J01_2")
myArray(4) = ("D01")
myArray(5) = ("D03")
myArray(6) = ("W01")
myArray(7) = ("W02")
myArray(8) = ("W03")
myArray(9) = ("W04")
myArray(10) = ("M01")
myArray(11) = ("M03")
myArray(12) = ("M04")
myArray(13) = ("M05")
myArray(14) = ("HJ01")
myArray(15) = ("J01")
myArray(16) = ("M02")
myArray(17) = ("J03")
myArray(18) = ("J04")
myArray(19) = ("J05")
myArray(20) = ("J06")
myArray(21) = ("J07")
myArray(22) = ("J08")
myArray(23) = ("J09")
myArray(24) = ("J10")
myArray(25) = ("J11")
myArray(26) = ("J12")
myArray(27) = ("J13")
myArray(28) = ("J14")
myArray(29) = ("J15")
myArray(30) = ("OT03")
myArray(31) = ("OT06")
myArray(32) = ("OT07")
myArray(33) = ("Checklist")
myArray(34) = ("ObjectGegevens")
myArray(35) = ("Grondstof")
myArray(36) = ("Drinkwaterinstallatie")
myArray(37) = ("WTB")
myArray(38) = ("Warmwaterleidingnet")
'array for the worksheets on the excel sheets
Dim myArray2(38)
myArray2(0) = Worksheets(1).name
myArray2(1) = Worksheets(1).name
myArray2(2) = Worksheets(42).name
myArray2(3) = Worksheets(17).name
myArray2(4) = Worksheets(2).name
myArray2(5) = Worksheets(15).name
myArray2(6) = Worksheets(22).name
myArray2(7) = Worksheets(3).name
myArray2(8) = Worksheets(28).name
myArray2(9) = Worksheets(29).name
myArray2(10) = Worksheets(4).name
myArray2(11) = Worksheets(6).name
myArray2(12) = Worksheets(29).name
myArray2(13) = Worksheets(46).name
myArray2(14) = Worksheets(7).name
myArray2(15) = Worksheets(16).name
myArray2(16) = Worksheets(5).name
myArray2(17) = Worksheets(13).name
myArray2(18) = Worksheets(12).name
myArray2(19) = Worksheets(47).name
myArray2(20) = Worksheets(9).name
myArray2(21) = Worksheets(13).name
myArray2(22) = Worksheets(14).name
myArray2(23) = Worksheets(14).name
myArray2(24) = Worksheets(32).name
myArray2(25) = Worksheets(1).name
myArray2(26) = Worksheets(1).name
myArray2(27) = Worksheets(1).name
myArray2(28) = Worksheets(1).name
myArray2(29) = Worksheets(8).name
myArray2(30) = Worksheets(19).name
myArray2(31) = Worksheets(33).name
myArray2(32) = Worksheets(18).name
myArray2(33) = Worksheets(27).name
myArray2(34) = Worksheets(25).name
myArray2(35) = Worksheets(36).name
myArray2(36) = Worksheets(26).name
myArray2(37) = Worksheets(20).name
myArray2(38) = Worksheets(38).name
i = 1
For Each nm In ThisWorkbook.Names
If nm.Visible Then
Set NamedRange = wb.Names.Item(i)
Set ws = NamedRange.RefersToRange.Parent
End If
Lr = wb.worksheet(Myarray(i)).range("A1:BA3000").Find(What:="*", _ LookIn:=xlValues, _
SearchOrder:=xlByRows, _ SearchDirection:=xlPrevious,
SearchFormat:=False).Row
Lc = wb.worksheet(Myarray(i)).range("A1:BA3000").Find(What:="*", _ LookIn:=xlValues, _
SearchOrder:=xlByColumns, _ SearchDirection:=xlPrevious, _
SearchFormat:=False).Column
Set Rng = ws.range(ws.Cells(1, 1), ws.Cells(Lr, Lc))
With wd
.Visible = True
.WindowState = wdWindowStateMaximize
With .Documents.Add(Template:="C:\RABP sjabloon clean.dotx")
With .Bookmarks
myArray(i).range.PasteExcelTable LinkedToExcel:=False, _
WordFormatting:=True, RTF:=False
Rng.Copy ws.range(i)
End With
End With
End With
i = i + 1
Next nm
End Sub
There are 2 ways that you could populate your array:
Method 1:
myArray = Split("Tappunten test1 Groslijst ...", " ")
Method 2:
Sub LoopThroughBookmarks()
Dim oBookmark As Bookmark
Dim myArray() As String
ReDim Preserve myArray(0)
For Each oBookmark In ActiveDocument.Bookmarks
ReDim Preserve myArray(UBound(myArray) + 1)
myArray(UBound(myArray) - 1) = oBookmark.Name
Next
End Sub
The bookmarks will be entered in the order in which they occur in the document, you may want to add some validation for the bookmarks so that you don't add some by mistake.
I've no idea how to match the bookmarks to the 2nd array :-/
I've ended up using these 2 pieces of code;
Sub Copy_to_word()
Dim wdApp As New Word.Application
Dim wdDoc As Word.Document
Dim i As Long
Dim names As Range
Application.ScreenUpdating = False
Application.EnableEvents = False
'location of the word template
Const StrDocNm As String = "C:\Word template V2.0.dotx"
If Dir(StrDocNm) = "" Then Debug.Print "file missing"
If Dir(StrDocNm) = MsgBox "Template not found"
If Dir(StrDocNm) = "" Then Exit Sub
'Could probebly make it a bit neather
Set wdDoc = wdApp.Documents.Add(Template:=StrDocNm)
wdApp.Visible = True
'All the named ranges have the same name as the bookmark
With ThisWorkbook
For i = 1 To .names.Count
On Error GoTo LosseCell:
.names(i).RefersToRange.Copy
Debug.Print .names(i).Name
'When the range is copied it starts the next macro.
'if there's an error it goes tot the next name range
Call PasteBookmark(wdDoc, .names(i).Name)
LosseCell:
Next
End With
Set wdDoc = Nothing: Set wdApp = Nothing
'because it takes some time it had the events and screenupdating turned off
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub
The second marcro is the part that pastes the range in to word;
Sub PasteBookmark(wdDoc As Word.Document, strBkMk As String)
Dim wdRng As Word.Range
With wdDoc
Application.ScreenUpdating = True 'not sure if this helps to be honest
Application.EnableEvents = True 'not sure if this helps to be honest
If .Bookmarks.Exists(strBkMk) Then
Set wdRng = .Bookmarks(strBkMk).Range
wdRng.Paste
.Bookmarks.Add strBkMk, wdRng
End If
End With
Set wdRng = Nothing
End Sub
Because the ranges vary in size i also have a macro that resizes the named ranges that can vary in row count;
Sub RangesAanpassen()
Dim NmdRngNames As Variant
Dim myLastRow As Long
Dim StrWsNaam As String
Dim strRangeNaam As String
Dim namRange As Name
Dim wsRange As Worksheet
Dim n As Variant
'the ranges that need to be resized are named the same as the sheets there
'on. It gave a lot of troubles because the sheets had names like "D01".
'Had to change all of them to a name that didn't look like a cell.
NmdRngNames = Array("D_03", "D_01", "J_01", "_6.4.3_Temperatuurmetingen",
"WTB", "Tappunten", "_6.4.2_Tappunten_inv", "Voorblad")
Application.ScreenUpdating = False
Application.EnableEvents = False
For Each n In NmdRngNames
strRangeNaam = n
On Error GoTo NextN: when the range is empty a "no object" error shows.
Set namRange = ActiveWorkbook.names.Item(strRangeNaam)
Set wsRange = Range(strRangeNaam).Worksheet
With wsRange
'the last cell can be anywhere in columns A to Z.
myLastRow = .Columns("A:Z").Find(What:="*", LookIn:=xlValues, _
SearchDirection:=xlPrevious, _
SearchOrder:=xlByRows).Row
End With
With namRange
.RefersTo = wsRange.Range(wsRange.Cells(1, 1), _
wsRange.Cells(myLastRow, 1))
End With
NextN:
Next
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub
Thanks for the great forum!
I have some background with VBA and I hate doing the same task 100's of times. I often have to make Solidworks drawings,these drawings are templates that are mostly just tables that I populate with data. There are 3 things that need to be changed on each sheet in the file (from sheet 3 to the last sheet). Normally I go into each sheet and do 3 find and replaces to change each sheet. then move on to the next sheet and repeat.
My plan was to have the code count the number of sheets, prompt the user for the first find/replace, replace that text on all sheets, then repeat for the 2nd replace, and again for the 3rd. I recorded a macro and added some code but I keep getting run-time errors (in code below). Every other macro I've recorded never gave me so many errors, if you can please help
Dim swApp As SldWorks.SldWorks
Dim swmodel As SldWorks.ModelDoc2
Dim swdraw As SldWorks.DrawingDoc
Dim Part As Object
Dim Otext As String
Dim Ntext As String
Dim Smax As Integer
Dim i As Integer
Dim swSheet As SldWorks.Sheet
Dim boolstatus As Boolean
Dim longstatus As Long, longwarnings As Long
Sub main()
Set swApp = Application.SldWorks
Set swmodel = swApp.ActiveDoc
'Set swSheet = swdraw.GetCurrentSheet
Smax = instance.GetSheetCount() - 3 ' runtime 424 error here
Set swSheet = swdraw.GetCurrentSheet ' runtime 91 error if i skip the line above
Otext = Application.InputBox("find this text")
Ntext = Application.InputBox("find this text")
For i = 1 To Smax
Set Part = swApp.ActiveDoc
'--------------------Find and Replace Annotations--------------------
Set swUtil = swApp.GetAddInObject("Utilities.UtilitiesApp")
Set swUtilFindReplaceAnnotations = swUtil.FindReplaceAnnotations
longstatus = swUtilFindReplaceAnnotations.InitPMPage()
'--------------------Block Recording--------------------
#If 0 Then
#End If
'--------------------UnBlock Recording------------------
swUtilFindReplaceAnnotations.FindText = Otext
swUtilFindReplaceAnnotations.ReplaceText = Ntext
swUtilFindReplaceAnnotations.options = gtFraMatchCase
swUtilFindReplaceAnnotations.AnnotationFilter = gtFraAllTypes
Part.ClearSelection2 True
Part.ClearSelection2 True
Part.ClearSelection2 True
Part.ClearSelection2 True
Part.ClearSelection2 True
longstatus = swUtilFindReplaceAnnotations.ReplaceAll()
'--------------------Block Recording--------------------
#If 0 Then
#End If
'--------------------UnBlock Recording------------------
longstatus = swUtilFindReplaceAnnotations.Close()
Part.SheetNext
Part.ViewZoomtofit2
Next i
End Sub
This should do the trick. It will popup a success window for each sheet however as that is how the SOLIDWORKS find replace utility works.
Dim swApp As SldWorks.SldWorks
Dim swModel As SldWorks.ModelDoc2
Dim swDrawingDoc As SldWorks.DrawingDoc
Dim vSheetNames As Variant
Dim longstatus As Long
Sub main()
Set swApp = Application.SldWorks
Set swModel = swApp.ActiveDoc
Set swDrawingDoc = swModel
vSheetNames = swDrawingDoc.GetSheetNames
Otext = InputBox("find this text")
Ntext = InputBox("find this text")
For i = 0 To UBound(vSheetNames)
swDrawingDoc.ActivateSheet (vSheetNames(i))
Set swUtil = swApp.GetAddInObject("Utilities.UtilitiesApp")
Set swUtilFindReplaceAnnotations = swUtil.FindReplaceAnnotations
longstatus = swUtilFindReplaceAnnotations.InitPMPage()
swUtilFindReplaceAnnotations.FindText = Otext
swUtilFindReplaceAnnotations.ReplaceText = Ntext
swUtilFindReplaceAnnotations.Options = gtFraWholeWord
swUtilFindReplaceAnnotations.AnnotationFilter = gtFraAllTypes
longstatus = swUtilFindReplaceAnnotations.ReplaceAll()
longstatus = swUtilFindReplaceAnnotations.Close()
Next i
End Sub
I have a VBA script written to query HP ALM database using OTA API.
I want to query the database using a Recursive CTE. I don't know how to write that script within this VBA script.
VBA Script:::
Sub Extractor()
Const QCADDRESS = "http://alm/qcbin"
Const DOMAIN = "DOMAIN"
Const PROJECT = "PROJECT"
Const QCUSR = "user.name"
Const QCPWD = "123456"
Dim QCConnection, com, recset
Dim XLS, Wkb, Wks, i
Set QCConnection = CreateObject("TDApiOle80.TDConnection")
QCConnection.InitConnectionEx QCADDRESS
QCConnection.Login QCUSR, QCPWD
QCConnection.Connect DOMAIN, PROJECT
Set com = QCConnection.Command
com.CommandText = "Select * from ALL_LISTS"
Set recset = com.Execute
Set XLS = CreateObject("Excel.Application")
XLS.Visible = False
Set Wkb = XLS.Workbooks.Add
Set Wks = Wkb.Worksheets(1)
i = 1
Wks.Cells(i, 1).Value = "Data"
If recset.RecordCount > 0 Then
i = 2
recset.First
Do While Not (recset.EOR)
Wks.Cells(i, 1).Value = recset.FieldValue(0) 'fieldvalue(0) because the query extract only 1 field.
i = i + 1
recset.Next
Loop
Wkb.SaveAs "C:\myfile.xls"
End If
Wkb.Close
XLS.Quit
QCConnection.Disconnect
Set recset = Nothing
Set com = Nothing
Set QCConnection = Nothing
Set XLS = Nothing
Set Wkb = Nothing
Set Wks = Nothing
End Sub
CTE Query::::
with ReqCTE
as
(
SELECT
RQ_REQ_ID,
RQ_REQ_NAME,
RQ_FATHER_ID,
0 as lvl
FROM
td.REQ
where
RQ_REQ_ID = {?Father_ID}
union all
select
Folders.RQ_REQ_ID,
Folders.RQ_REQ_NAME,
Folders.RQ_FATHER_ID,
Child.lvl +1
from
ReqCTE as Child
join td.REQ as Folders on Folders.RQ_REQ_ID = Child.RQ_FATHER_ID
);
select * from ReqCTE;
Here is your code with your query embedded and your query variable declared as a VBA variable and referenced in the SQL script:
Sub Extractor()
Const QCADDRESS = "http://alm/qcbin"
Const DOMAIN = "DOMAIN"
Const PROJECT = "PROJECT"
Const QCUSR = "user.name"
Const QCPWD = "123456"
Dim par(0) As Variant
Dim QCConnection, com, recset
Dim XLS, Wkb, Wks, i
Set QCConnection = CreateObject("TDApiOle80.TDConnection")
QCConnection.InitConnectionEx QCADDRESS
QCConnection.Login QCUSR, QCPWD
QCConnection.Connect DOMAIN, PROJECT
Set com = QCConnection.Command
par(0) = 4 'set parameter value for Father_ID in SQL
com.CommandText = "with ReqCTE as (" & _
"SELECT RQ_REQ_ID, RQ_REQ_NAME, RQ_FATHER_ID, 0 as lvl FROM td.REQ " & _
"where RQ_REQ_ID = ? " & _
"Union all " & _
"select Folders.RQ_REQ_ID, Folders.RQ_REQ_NAME, Folders.RQ_FATHER_ID, Child.lvl +1 from ReqCTE as Child " & _
"join td.REQ as Folders on Folders.RQ_REQ_ID = Child.RQ_FATHER_ID); " & _
"select * from ReqCTE;"
Set recset = com.Execute(, par)
Set XLS = CreateObject("Excel.Application")
XLS.Visible = False
Set Wkb = XLS.Workbooks.Add
Set Wks = Wkb.Worksheets(1)
i = 1
Wks.Cells(i, 1).Value = "Data"
If recset.RecordCount > 0 Then
i = 2
recset.First
Do While Not (recset.EOR)
Wks.Cells(i, 1).Value = recset.FieldValue(0) 'fieldvalue(0) because the query extract only 1 field.
i = i + 1
recset.Next
Loop
Wkb.SaveAs "C:\myfile.xls"
End If
Wkb.Close
XLS.Quit
QCConnection.Disconnect
Set recset = Nothing
Set com = Nothing
Set QCConnection = Nothing
Set XLS = Nothing
Set Wkb = Nothing
Set Wks = Nothing
End Sub
UPDATED to avoid injection
When i try to upload multiple pictures to the database my code works fine and all the pictures show in the gallery, but when i try to modify the picture in the database, and modify one picture it deletes the rest of the pictures from the database. The recordset isnt deleted and the rest of the information stays the same, its just the 5+ places i have for the pictures whose data gets deleted. here is my code so far..
message.Text = "please wait"
pics.Visible = False
'wherepics are stored
Dim savepath As String = Server.MapPath("/cgi-bin/properties/")
Dim tfn0 As String = ""
Dim tfn1 As String = ""
'dims the filenames a variables
Dim img0 As String = pic0.FileName
Dim img1 As String = pic1.FileName
'this is the set of paths to check
'this will check for redundencies in the database so no dublicate file names will occur
Dim ptc0 As String = savepath + img0
Dim ptc1 As String = savepath + img1
Dim url0 As String = ""
Dim url1 As String = ""
Dim counter As Integer = 2
If (System.IO.File.Exists(ptc0)) Then
While (System.IO.File.Exists(ptc0))
tfn0 = counter.ToString = img0
ptc0 = savepath + tfn0
counter = counter + 1
End While
ElseIf (System.IO.File.Exists(ptc1)) Then
While (System.IO.File.Exists(ptc1))
tfn1 = counter.ToString = img1
ptc1 = savepath + tfn1
counter = counter + 1
End While
End If
Dim sp0 As String = savepath + img0
Dim sp1 As String = savepath + img1
If Not pic0.FileName = Nothing Then
pic0.SaveAs(sp0)
img0 = pic0.FileName
url0 += "pic_main"
url1 += img0
End If
If Not pic1.FileName = Nothing Then
If pic0.FileName = Nothing Then
pic1.SaveAs(sp1)
img1 = pic0.FileName
url0 += "pic_one"
url1 += img1
Else
pic1.SaveAs(sp1)
img1 = pic0.FileName
url0 += ", pic_one"
url1 += ", " & img1
End If
End If
Dim datanames() As String = {url0}
', "pic_six", "pic_seven", "pic_eight", "pic_nine"
Dim datavalues() As String = {url1}
', file6, file7, file8, file9
DB.UpdateCommand(datanames, datavalues, "property", "property_id = " & Request.QueryString("id")) ', true)
Response.Redirect("finished.aspx")
I have found the solution it was looking at all of the file upload controls, since nothing was in them it would reference those fields I had this figured out a while ago, got busy and never found time to post my answer. in the database and delete anything that was in it and replace it with a blank space. I changed the code a bit to where the users chooses the slot in which they want to update, then carry over a qstring instead of having it update all of them at once