Found a similar post on this question, but it was using an SQL Query and I'm using a DLookup.
I'm importing an Excel sheet to Access.
I'm getting the run-time 3075 - Syntax error (missing operator)... '[Component]='don't have/want a car'.
That particular Component already exists in the DB and it errors out at the comparison.
It's either the ' or the / that are causing the hang-up
Oh and I went with Variant on the tmpComponent b/c if I go String I get an Object required error at the Set tmpComponent = ... line. Maybe that is the problem, just not really sure.
Here is my Code and the bold is where the error occurs.
Thank you in advance for any direction you can provide.
Set rsCat = db.OpenRecordset("Categories", dbOpenDynaset, dbSeeChanges)
Dim x As Integer: x = 2
Dim LRow As Integer: LRow = ExLWb.Sheets("Categories").Cells(Rows.Count, 2).End(xlUp).Row
Dim tmpPFId As Variant, tmpCategory As Variant, tmpComponent As Variant, tmpSyntax As Variant, tmpCycle As Variant
Dim NewItem As Integer
NewItem = 0
'******************* LOOP THROUGH SPREADSHEET UPDATING CATEGORY TABLE
For x = 2 To LRow
Set tmpPFId = ExLWs.Cells(x, 2)
Set tmpCategory = ExLWs.Cells(x, 3)
Set tmpComponent = ExLWs.Cells(x, 4)
Set tmpSyntax = ExLWs.Cells(x, 5)
Set tmpCycle = ExLWs.Cells(x, 9)
**If IsNull(DLookup("[Component]", "[Categories]", "[Component]= '" & tmpComponent & "'")) Then**
rsCat.AddNew
rsCat!PF_ID = tmpPFId
rsCat!Category = tmpCategory
rsCat!component = tmpComponent
rsCat!Syntax = tmpSyntax
rsCat!Active = True
rsCat!Available = True
rsCat!Cycle = tmpCycle
rsCat.Update
NewItem = NewItem + 1
End If
Next x
Disregard, I figured out I should have gone with:
If IsNull(DLookup("[Category]", "[Categories]", "[Category]= """ & tmpCategory & """ & [Component]= """ & tmpComponent & """")) Then
Related
I tried to make a macro that takes all the comments in a word document, filters based on the comment text and then inserts them in excel with the associated text in a note.
I tried each step iteratively and I managed to copy the comments and pasting the wanted results in the same word document. Then I managed to manipulate excel by adding columns and notes.
Everything broke when I integrated the excel part with the comment extraction part. The errors were invalid procedure call for the line with rightParPos = InStr(leftParPos, comment, ")") which I hadn't touched in a while, so I tried outputting the parameters... That lead to a completely different error - an indexing error for the categories array when categoryCount was 0, which also was very strange. After that I tried removing a strange character in a string and then I suddenly got some kind of "can't connect to excel" at Set xlWB = xlApp.Workbooks.Open(FileName:=xlPath).
It seems completely random to me. I'm thinking that it might be some kind of limit or bug in the Microsoft Word environment that is causing these problems. Anyone knowing what could be a cause of these strange errors?
I couldn't find anything out of the ordinary with my code, but maybe someone on S.O. sees something that immediately looks strange. Sorry for the very messy code.
Sub Test()
Dim comment, text As String
Dim pageNr As Integer
Dim codePrefix, fileName As String
Dim newLinePos, leftParPos, rightParPos As Integer
Dim commentNr As Integer
Dim codeWorksheetIndex As Integer
Dim xlFile, xlDir, xlPath As String
'Excel'
Dim xlApp As Object
Dim xlWB As Object
On Error Resume Next
Set xlApp = GetObject(, "Excel.Application")
If Err Then
Set xlApp = CreateObject("Excel.Application")
End If
On Error GoTo 0
xlFile = "TEST"
xlDir = "My\Directory\path\" 'censored
xlPath = xlDir & xlFile
Set xlWB = xlApp.Workbooks.Open(FileName:=xlPath)
codePrefix = "a-code" 'censored
fileName = Left(ActiveDocument.Name, Len(ActiveDocument.Name)-5)
'insert a column as second column in each spreadsheet'
For sheet_index = 1 to 3
With xlWB.Worksheets(sheet_index)
.Range("B:B").Insert
.Cells(1, 2).Formula = fileName
End With
Next sheet_index
For commentNr = 1 To ActiveDocument.Comments.Count
Dim category As String
Dim categories(1 to 2) As String
Dim categoryCount As Integer
Dim numLeft, numRight as Integer
'Dim j As Integer
comment = LCase(ActiveDocument.Comments(commentNr).Range)
text = ActiveDocument.Comments(commentNr).Scope
pageNr = ActiveDocument.Comments(commentNr).Scope.Information(wdActiveEndPageNumber)
'find newline'
newLinePos = InStr(comment, vbCr)
If newLinePos = 0 Then
newLinePos = InStr(comment, vbLf)
If newLinePos = 0 Then
newLinePos = InStr(comment, vbCrLf)
if newLinePos = 0 then
newLinePos = InStr(comment, Chr(10))
if newLinePos = 0 then
ActiveDocument.Content.InsertAfter Text:="ERROR: comment " & commentNr & " misses newline!" & vbNewLine
End If
End If
End If
End If
'set to initial index for leftpar instr'
rightParPos = 1
categoryCount = 0
Do
leftParPos = InStr(rightParPos, comment, "(")
rightParPos = InStr(leftParPos, comment, ")")
If leftParPos > 0 and rightParPos > 0 Then
numLeft = rightParPos-1
numRight = numLeft - leftParPos
category = Trim(Right(Left(comment, numLeft), numRight))
categories(categoryCount) = category
categoryCount = categoryCount + 1
End If
Loop While leftParPos > 0 And rightParPos > 0
comment = fileName & " (s. " & pageNr & ")" & vbNewLine & Trim(Right(comment, Len(comment)-newLinePos))
If Instr(LCase(comment), codePrefix) = 1 Then
For categoryIndex = 0 To categoryCount-1
category = categories(categoryIndex)
If category = "category1" Then
codeWorksheetIndex = 1
ElseIf category = "category2" Then
codeWorksheetIndex = 2
ElseIf category = "category3" Then
codeWorksheetIndex = 3
End If
With xlWB.Worksheets(codeWorksheetIndex)
.Cells(commentNr+1, 2).Formula = text
.Cells(commentNr+1, 2).NoteText comment 'this only worked without =
End With
Next categoryIndex
End If
Next commentNr
End Sub
There are two critical problems with the code that were overlooked and then there was one third problem that wasn't due to the code but which also resulted in errors.
As #TimWilliams mentioned, one case where leftParPos = 0 was unhandled.
The indexing of categories was entirely wrong and faulty in the code.
The strangest error was due to having the excel file on an external harddrive that disconnected and therefore making excel not responding.
I'm trying to take a table of data from Excel and import it into MS Project
Here is a screenshot of what I have in Excel:
CC: Excel table of column headers of: WBS, Task Name, Start Date, Finish Date, Duration, Work, and Resource Name with rows of data that are independent of resource name assignment.
Here is a screenshot of what I am looking for a VBA code to be able to produce from Excel to MS Project:
CC: MS Project file showing columns of WBS, Task Name, Start Date, Finish Date, Duration, Work, and Resource Name with resource names grouped by WBS.
I've tried copy and paste, but there has got to be a better option with VBA (I hope?)
If there are questions, I'm happy to answer them.
I really appreciate any help anyone can give me!
EDIT:
Here is the VBA I have now:
Sub ExceltoProject()
Dim pjapp As Object
Dim strValue, strStartDate, strEndDate, Strresource As String
Dim newproj
Set pjapp = CreateObject("MSProject.Application")
If pjapp Is Nothing Then
MsgBox "Project is not installed"
Exit Sub
End If
pjapp.Visible = True
Set newproj = pjapp.Projects.Add
newproj.Title = "ExcelExtract"
Set ActiveProject = newproj
For i = 2 To 4
strWBS = Worksheets("LABOR_IMS_INPUT").Range("A" & i)
strTaskName = Worksheets("LABOR_IMS_INPUT").Range("B" & i)
strStartDate = Worksheets("LABOR_IMS_INPUT").Range("C" & i)
strEndDate = Worksheets("LABOR_IMS_INPUT").Range("D" & i)
strDuration = Worksheets("LABOR_IMS_INPUT").Range("E" & i)
Strresource = Worksheets("LABOR_IMS_INPUT").Range("F" & i)
strWork = Worksheets("LABOR_IMS_INPUT").Range("G" & i)
newproj.Tasks.Add (strValue & " " & Strresource)
newproj.Resources.Add.Name = Strresource
newproj.Tasks(i - 1).ResourceNames = Strresource
Next i
End Sub
Public Function ExistsInCollection(pColl, ByVal pKey As String) As Boolean
On Error GoTo NoSuchKey
If VarType(pColl.Item(pKey)) = vbObject Then
' force an error condition if key does not exist
End If
ExistsInCollection = True
Exit Function
NoSuchKey:
ExistsInCollection = False
End Function
But this is what I get:
CC: Excel file and MS Project file. MS Project file only has "resource sheet name" data.
Any ideas what is happening. That I'm doing wrong?
Sorry for previous issues with clarity, I am visually impaired and trying to code!
This code will take the data from the Excel sheet to create a new Project schedule. No need to set both Finish and Duration fields as the Finish date will be determined by the Start date and Duration.
Sub ExceltoProject()
Dim pjapp As Object
Dim newproj As Object
Set pjapp = CreateObject("MSProject.Application")
If pjapp Is Nothing Then
MsgBox "Project is not installed"
Exit Sub
End If
pjapp.Visible = True
Set newproj = pjapp.Projects.Add
newproj.Title = "ExcelExtract"
Dim wst As Worksheet
Set wst = ThisWorkbook.Worksheets("LABOR_IMS_INPUT")
Dim i As Long
For i = 2 To 4
newproj.Tasks.Add
newproj.Tasks(i - 1).Name = wst.Cells(i, 2)
newproj.Tasks(i - 1).WBS = wst.Cells(i, 1)
newproj.Tasks(i - 1).Start = CDate(wst.Cells(i, 3))
newproj.Tasks(i - 1).Duration = wst.Cells(i, 5) & "d"
newproj.Tasks(i - 1).ResourceNames = wst.Cells(i, 7)
newproj.Tasks(i - 1).Work = wst.Cells(i, 6) & "h"
Next i
End Sub
The issue I've got here is that
iRow = PullRange.Find(What:=a(x, 0)).Row - 1
Throws above mentioned error in the middle of a loop. The thing is it works for the first handful of iterations of x, but at x = 11/iRow = 30 it breaks and I've no clue why. There's nothing unique about that particular row and yet it crashes, has anyone any clue as to why?
Let me know if more info is needed.
Public Sub DataDump(Sql As String, PullColumn As String)
Dim a() As Variant
Dim iRow As Integer
Dim PullRange As Range
Dim DumpRange As Range
Dim x As Integer
Dim y As Integer
Set PullRange = Range(PullColumn & ":" & PullColumn)
Set DumpRange = Range("H1")
Set recs = New ADODB.Recordset
recs.Open Sql, con, adOpenDynamic
a = recs.GetRows
'a(y, x)
For x = 0 To UBound(a, 2)
If IsNull(a(0, x)) Then GoTo none
iRow = PullRange.Find(What:=a(0, x)).Row - 1
If iRow = 0 Then GoTo none
For y = 1 To UBound(a, 1)
Debug.Print a(y, x)
If IsNull(a(y, x)) Then GoTo Err
DumpRange.Offset(iRow, y) = a(y, x)
Err:
Next y
none:
Next x
End Sub
#Rory Was right. Unclean data caused the loop to break and I couldn't see the difference because the difference was minute, after inserting data set anew from the same source it fixed itself. Lesson learned.
I want to export data from Excel to a pdf-Form using vba.
I used this approach:
https://forums.adobe.com/thread/302309
When I copy just one field it works, but I want to copy all the fields from A1:K2 where the field titles are always in the top and the content in the rows below.
I think my problem is that I don't switch back to Excel when I am trying to copy the next value and field title. But I don't know how to do it properly.
So I would be really glad if someone could tell me.
The files could be downloaded here:
http://www.xn--frank-mller-zhb.net/Formulardings.zip
Sub Pdfdings()
Dim gApp As Acrobat.CAcroApp
Dim avdoc As Acrobat.CAcroAVDoc
Dim gPDDoc As Acrobat.CAcroPDDoc
Const DOC_FOLDER As String = "C:\Users\Frank\Documents"
Dim x As Boolean
Set gApp = CreateObject("AcroExch.App")
Set gPDDoc = CreateObject("AcroExch.PDDoc")
Set avdoc = CreateObject("AcroExch.AVDoc")
'Hides Acrobat - So Far So Good
'gApp.Hide
Dim FormApp As AFORMAUTLib.AFormApp
Dim AcroForm As AFORMAUTLib.Fields
Dim Field As AFORMAUTLib.Field
Dim z, i, j, n As Integer
Dim wksTab1 As Worksheet
Dim Feld, Inhalt As String
Set wksTab1 = Sheets("Tabelle2")
'Open PDF that I choose. Acrobat still has not flashed on my screen
j = 1
i = 2
While i < 3
x = avdoc.Open(DOC_FOLDER & "\formular_ve01a.pdf", "temp")
'Acrobat Now Pops up on my screen. However, I get an error without this line. avdoc.Show works the same as Maximize it seems.
avdoc.Maximize (1)
'Hides it again, right after it opens. This creates a flash
'gApp.Hide
Set FormApp = CreateObject("AFormAut.App")
While j < 39
'If the Maximize line is not there, this is where I receive error about document viewer
Feld = wksTab1.Cells(1, j).Value
Inhalt = wksTab1.Cells(i, j).Value
For Each Field In FormApp.Fields
If Field.Name = Feld Then
Field.Value = Inhalt
End If
Next
j = j + 1
Wend
Dim sDoc
Set sDoc = avdoc.GetPDDoc
saveOk = sDoc.Save(1, DOC_FOLDER & "\OK_Formular" & wksTab1.Cells(1, 1).Value & ".pdf")
avdoc.Close (1)
gApp.Exit
i = i + 1
Wend
End Sub
Set A1:K2 as your print range
Set your printer to a PDF Writer (CutePDF or PDF995 or other)
Print
solution I got by the help of another forum
<pre>While j < 39
'If the Maximize line is not there, this is where I receive error about document viewer
Feld = wksTab1.Cells(1, j).Value
Inhalt = wksTab1.Cells(i, j).Value
FormApp.Fields(Feld).Value = Inhalt
j = j + 1
Wend
Thank you everyone!
EDITED
If you guys have a link that might help with this problem I'd really like to read it, because so far I haven't seen anything very useful.
In access I'm trying to export arbitrary data to excel, create multiple charts (right now just working on a pie chart), format these charts and then send them to a blank (Chart) sheet. So far I've exported the data and am able to create the charts, I just have no idea how to format them.
The formatting I want to do is to get rid of the legend, put data labels with the name, value, and percentage, and move it to a "Chart" sheet.
Edit I am now able to get rid of the legend as well as insert the data labels with name, value and percentage. I am still stuck on moving the Chart object to a new sheet, code at bottom.
I've also tried to record a macro in excel, edit it slightly and then move it over to access but I keep erroring out, usually with an error similar to "This object doesn't have that method". Below I'll include a test table that I might get and how I create the pie chart.
Code:
Function Excel_Export_Two_Column()
Dim db As DAO.Database, rs As DAO.Recordset
Dim WBO As Object, WSO As Object, WSO2 As Object, XLO As Object, oChart As Object
Dim x As Long, y As Long, z As Integer, strTab As String, strcompany As String
Dim endTable As Long
Dim tempName As String, tempNum1 As Long, tempNum2 As Long, totalEnd As Long
z = 1
Set db = CurrentDb()
Set rs = db.OpenRecordset("QRY2Col")
Set XLO = CreateObject("Excel.Application")
XLO.Application.Workbooks.Add
Set WBO = XLO.Application.ActiveWorkbook
Set WSO = WBO.Worksheets(1)
Set WSO2 = WBO.Worksheets(2)
WSO.Name = Left("export", 31)
For y = 0 To rs.Fields.Count - 1
WSO.Cells(1, 1) = "Num"
WSO.Cells(1, y + 2) = rs(y).Name
Next y
x = 1
Do While Not rs.EOF()
x = x + 1
WSO.Cells(x, 1) = x - 1
For y = 0 To rs.Fields.Count - 1
WSO.Cells(x, y + 2) = Trim(rs(y))
Next y
rs.MoveNext
DoEvents
Loop
WSO.Cells.Rows(1).AutoFilter
WSO.Application.Cells.Select
WSO.Cells.EntireColumn.AutoFit
x = 1
Do While WSO.Cells(x, 1) <> ""
x = x + 1
Loop
endTable = x - 1
WSO2.Cells(1, 1) = "Name"
WSO2.Cells(1, 2) = "Num"
totalEnd = 2
For x = 2 To endTable
If (WSO.Cells(x, 2) <> "") Then
tempName = WSO.Cells(x, 2)
tempNum1 = WSO.Cells(x, 3)
For y = 2 To totalEnd
If (WSO2.Cells(y, 1) = tempName) Then
tempNum2 = WSO2.Cells(y, 2)
WSO2.Cells(y, 2) = tempNum1 + tempNum2
Exit For
ElseIf (y = totalEnd) Then
WSO2.Cells(y, 1) = tempName
WSO2.Cells(y, 2) = tempNum1
totalEnd = totalEnd + 1
End If
Next y
End If
Next x
Set oChart = WSO2.ChartObjects.Add(500, 100, 500, 300).Chart
oChart.SetSourceData Source:=WSO2.Range("A1").Resize(totalEnd - 1, 2)
oChart.ChartType = 5
strcompany = "Export"
If Dir(CurrentProject.Path & "\COLA_AR_" & Format(Date, "yyyymm") & "_XXX_" & strcompany & ".xlsx") <> "" Then
Kill CurrentProject.Path & "\COLA_AR_" & Format(Date, "yyyymm") & "_XXX_" & strcompany & ".xlsx"
End If
Call WBO.SaveAs(CurrentProject.Path & "\COLA_AR_" & Format(Date, "yyyymm") & "_test_2_Col.xlsx")
WBO.Close savechanges:=True
Set WBO = Nothing
XLO.Application.Quit
Set XLO = Nothing
rs.Close
db.Close
End Function
Table: Note that this table is in a Query (named "QRY2Col") in Access
Field1 Field2
CTOD 64646515
BFTBC2 6656532
WTOW 451512355
DT3 684321818
STC2 652553548
BFTBC2 12
DT3 84954987
ATCR 99999999
CTOD 64185435
BFTBC2 321569846
STC2 6543518
STC2 3518684
ATCR 35481354
Code for data labels
Set oChart = WSO2.ChartObjects.Add(500, 100, 500, 300).Chart
oChart.SetSourceData Source:=WSO2.Range("A1").Resize(totalEnd - 1, 2)
' Number corresponds to a pie chart
oChart.ChartType = 5
' Adds data Labels
oChart.SeriesCollection(1).HasDataLabels = True
' Format chart
oChart.SeriesCollection(1).DataLabels.ShowCategoryName = True
oChart.SeriesCollection(1).DataLabels.ShowPercentage = True
oChart.SeriesCollection(1).HasLeaderLines = True
oChart.Legend.Delete
Attempted code to move chart
Below is an example of what I recorded (edited by adding "oChart") but this still doesn't work. The problem that gets highlighted is the "xlLocationAsNewSheet" and VBA says that the "Variable is not defined".
oChart.Location Where:=xlLocationAsNewSheet
Thank you,
Jesse Smothermon
For the last part, try this:
oChart.Location Where:=1
' xlLocationAsNewSheet = 1
' xlLocationAsObject = 2
' xlLocationAutomatic = 3
As David pointed out, you cannot use the types/enums etcetera defined in the Excel object library without a reference to it, thus you are stuck using integer constants instead.