I am trying to read a table from a worksheet and storing in an listobject. I need to use this table data multiple time and I dont want to access worksheet every time I need table data. I think accessing worksheet everytime will slow down the performance.
Also I need to refer table data based on header name.
I was thinking of writing something like this.
public Tbl_MyTable as listobject
public Arr as variant
Set Tbl_MyTable = Workbooks("Myworkbook").worksheets("Myworksheet").ListObjects("Tbl1")
tRows = Tbl_MyTable .DataBodyRange.Rows.Count
for i=1 to 10
config= ArrConfig(i)
call readtable(tRows, config)
Set Destination = workbooks("x").sheets("y").Range("A2")
Destination.Resize(1,UBound(Arr, 1)).Value = Arr
'Create the table based on the populated data.
Set populated_area = Destination.CurrentRegion
Set Create_Table = .ListObjects.Add(xlSrcRange, populated_area, , xlYes)
Create_Table.name = (.name & "_tbl")
Create_Table.TableStyle = "TableStyleMedium15"
'Select this newly created table and do some data reformating
With ActiveSheet.ListObjects("" & Tbl_name & "").Range.Select
'Change entire Table font
With Selection.Font
.name = "Calibri Light"
.Size = 10
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ThemeColor = xlThemeColorLight1
.TintAndShade = 0
.ThemeFont = xlThemeFontMajor
End With
End with
...
...
...
'Inside Sub readtable
For i = 1 To tRows
if config= A
Arr(i) = Range("Tbl_MyTable[Header1]")(i).Value
else if config =B
Arr(i) = Range("Tbl_MyTable[Header2]")(i).Value
else
Arr(i) = Range("Tbl_MyTable[Header3]")(i).Value
end if
.
.
Problem is that it works only for first iteration of top level loop.
Next time I get following error (Somehow I am getting multiple errors every time I run it. Not all appear everytime)
Run-time error '1004' : Method 'Range' of object'_Global' failed
Error number: 90 Subscript out of range
Any idea what might be wrong here. I guess looking this code again and again I am hitting a wall now. I need another set of eyes to help me.
Related
A little background:
A former employee wrote a VBA program to run in AutoCAD to generate G-code based off of CAD entities. The immediate problem is that it currently only runs in AutoCAD 2002 on a computer running Windows XP on a virtual desktop. Obviously, that doesn't work so I'm trying to get it to work on BricsCad V21. My current issue is that I keep getting a Run time error 91 at the following place and I do not understand what the issue is or how to overcome it.
Please note that I am a VERY beginner programmer and am still trying to wrap my head around how all of this works. Any help you can provide would be most appreciated.
Public ExcelApp As Excel.Application
Public wbkObj As Excel.Workbook
Public shtObj As Excel.Worksheet
Public rngObj As Excel.Range
These are the relevant declarations at the beginning of the program
Sub CAM_A_CHEST()
Set ExcelApp = CreateObject("Excel.Application")
Set wbkObj = ExcelApp.workbooks.Add
Set shtObj = ExcelApp.Worksheets(1)
If Err <> 0 Then
MsgBox "Could not start Excel", vbExclamation
End
Else
ExcelApp.Visible = True
Application.Visible = True
ExcelApp.ScreenUpdating = True
Set rngObj = shtObj.Range(Cells(1, 1), Cells(1, 5))
With rngObj
.NumberFormat = "0"
.Font.Name = "Arial"
.Font.FontStyle = "Bold"
.Font.Size = 10
'.Font.ColorIndex = xlAutomatic
End With
With shtObj.Range(Cells(2, 1), Cells(2000, 13))
.NumberFormat = "0.000"
.Font.Name = "Arial"
.Font.FontStyle = "Regular"
.Font.Size = 9
.Value = ""
End With
With shtObj.Range(Cells(2, 5), Cells(2000, 5))
.NumberFormat = "0"
End With
shtObj.Range("A1:D1").Select
Selection.NumberFormat = "General"
shtObj.Cells(1, 1).ColumnWidth = 18
shtObj.Cells(1, 1) = "Layer"
shtObj.Cells(1, 2) = "Center X"
shtObj.Cells(1, 3) = "Center Y"
shtObj.Cells(1, 4) = "Diameter"
shtObj.Cells(1, 5) = "Sort"
shtObj.Cells(1, 7).Font.FontStyle = "Bold"
shtObj.Cells(1, 7).Font.Size = 10
Range("A2").Select
ActiveWindow.FreezePanes = True
End If
'ExcelApp.Visible = False
transZ$ = "2.00"
divNum$ = ""
grpNum$ = "0"
Load UserForm1
Load UserForm2
Load UserForm3
Load procUserForm
Call UserForm_Initialize
That is the chunk of code that opens Excel, formats the Worksheet, and prepares for inputs from AutoCAD. Later on in the code, The following Sub is called:
Sub CAM_TopAndBottomBoards()
Dim I As Integer
Dim mspaceObj As AcadObject
Dim centerPoint As Variant
Dim ExcelApp As Excel.Application
increment = 0
Call InitializeCounters
SelectStuff:
'Find entities representing Pitman Holes, Pipe Holes, etc., among items selected,
' dump data into Excel sheet
ExcelApp.Visible = True
It's that last line that is generating the error.
At this point I've spent a couple of days on this issue and I'm completely stuck. Help!
I am trying to copy the contents (text and format) from a text box on one sheet to another text box on another sheet within the same workbook. I have been able to successfully copy over almost everything, but the justification (center/left/right) is not working for each individual line. I am doing this in a very clunky way: copy the text, then loop through each character to get the format set. There does not seem to be an easy way in excel vba to copy both the text and ALL of the format over. Essentially I am trying to do a "select all (Cntrl-A)", "copy (Cnrl-C)" on the origin textbox, then do a "paste special (keep source formatting)" on the destination text box. IT works wonderfully using the mouse, but I do not want to do that. I just want to run a macro to do the same thing. Also, I noted that when the macro runs, the destination text box applies justification global to the text and I am no longer able to individually select a single line and set its justification (i.e. either all lines are centered or all lines are left justified vs. being able to adjust each line individually). Again, this weird behavior only happens after the macro is run. If I use the mouse cut-and-paste method, the text is able to be justified line-by-line again. Here is my clunky code:
Sub Update_CARD_LEG_BACK()
' Set varibles to reduce typing and make changing origin and destination text boxes easier.
Set Orig = Sheets("MAIN_INPUT2").Shapes("CARD_LEG_BACK")
Set Orig_Sheet = Sheets("MAIN_INPUT2")
Set Dest = Sheets("CARD_LEGACY").Shapes("BACK")
Set Dest_Sheet = Sheets("CARD_LEGACY")
'Copy text from origin text box to destination text box. Copies only the text NO formating.
Dest.TextFrame.Characters.Text = Orig.TextFrame.Characters.Text
For i = 1 To Len(Orig.TextFrame.Characters.Text)
Dest.TextFrame.Characters(i, 1).Font.Underline = Orig.TextFrame.Characters(i, 1).Font.Underline
With Dest.TextFrame2.TextRange.Characters(i, 1)
.Text = Orig.TextFrame2.TextRange.Characters(i, 1).Text
With .Font
.Name = Orig.TextFrame2.TextRange.Characters(i, 1).Font.Name
.Size = Orig.TextFrame2.TextRange.Characters(i, 1).Font.Size
.Bold = Orig.TextFrame2.TextRange.Characters(i, 1).Font.Bold
.Strikethrough = Orig.TextFrame2.TextRange.Characters(i, 1).Font.Strikethrough
.Superscript = Orig.TextFrame2.TextRange.Characters(i, 1).Font.Superscript
.Subscript = Orig.TextFrame2.TextRange.Characters(i, 1).Font.Subscript
.Fill.ForeColor.RGB = Orig.TextFrame2.TextRange.Characters(i, 1).Font.Fill.ForeColor.RGB
.Fill.BackColor.RGB = Orig.TextFrame2.TextRange.Characters(i, 1).Font.Fill.BackColor.RGB
.Fill.Visible = Orig.TextFrame2.TextRange.Characters(i, 1).Font.Fill.Visible
.Fill.Transparency = Orig.TextFrame2.TextRange.Characters(i, 1).Font.Fill.Transparency
End With
With .ParagraphFormat
.BaselineAlignment = Orig.TextFrame2.TextRange.Characters(i, 1).ParagraphFormat.BaselineAlignment
.SpaceWithin = Orig.TextFrame2.TextRange.Characters(i, 1).ParagraphFormat.SpaceWithin
.SpaceBefore = Orig.TextFrame2.TextRange.Characters(i, 1).ParagraphFormat.SpaceBefore
.SpaceAfter = Orig.TextFrame2.TextRange.Characters(i, 1).ParagraphFormat.SpaceAfter
.IndentLevel = Orig.TextFrame2.TextRange.Characters(i, 1).ParagraphFormat.IndentLevel
.FirstLineIndent = Orig.TextFrame2.TextRange.Characters(i, 1).ParagraphFormat.FirstLineIndent
.Alignment = Orig.TextFrame2.TextRange.Characters(i, 1).ParagraphFormat.Alignment
.HangingPunctuation = Orig.TextFrame2.TextRange.Characters(i, 1).ParagraphFormat.HangingPunctuation
End With
End With
Next i
'Copy fill color of origin text box to destination text box. Also copies transparancy (required for 'no fill' option to copy correctly).
Dest.Fill.ForeColor.RGB = Orig.Fill.ForeColor.RGB
Dest.Fill.Transparency = Orig.Fill.Transparency
End Sub
You could replace the second with a copy of the first:
Sub Tester()
ReplaceWithCopy Sheet1.Shapes("SourceTB"), Sheet2.Shapes("DestTB")
End Sub
Sub ReplaceWithCopy(shpSrc As Shape, shpDest As Shape)
Dim nm As String
shpSrc.Copy
shpDest.Parent.Paste
With shpDest.Parent.Shapes(shpDest.Parent.Shapes.Count)
.Left = shpDest.Left
.Top = shpDest.Top
.Width = shpDest.Width
.Height = shpDest.Height
nm = shpDest.Name
shpDest.Delete 'remove the shape being replaced
.Name = nm 'rename copy to just-deleted shape
End With
End Sub
I have a VBA routine in Excel which opens a word.app. All the set variables work fine in the multiple runs except for one thing. I hope you can help me out!
The relevant code in my opinion:
Dim WordApp As Word.Application
Dim WordDoc As Word.Document
'load format
Set WordApp = CreateObject("Word.Application")
WordApp.Visible = True
Set WordDoc = WordApp.Documents.Add(Template:=FormatLocation & FormatFile)
Call MakeTableFields(OHIBSingleEntity, WordDoc)
WordDoc.SaveAs FileName:=SaveFile, FileFormat:=wdFormatXMLDocument, AddtoRecentFiles:=False
WordDoc.Close
WordApp.Quit
Set OHIBSingleEntity = Nothing
Set WordDoc = Nothing
Set WordApp = Nothing
-----------------------------------------------------------------------------
Private Sub MakeTableFields(EntityFields As Recordset, WordDoc As Word.Document)
'make table sub
Dim PropTbl As Word.Table
Dim RangeCT As Word.Range
Set RangeCT = WordDoc.Content
With RangeCT.Find
.Text = "#InvoegenTabelISB"
.Format = False
.Wrap = wdFindContinue
.MatchWildcards = False
.Execute
End With
Recordcounter = EntityFields.RecordCount
'Problem is here:
Set PropTbl = WordDoc.Tables.Add(RangeCT, RoundUp(Recordcounter / 2, 0), 4)
'after this formatting and filling the just created table with the EntityFields dataset
Set RangeCT = Nothing
Set PropTbl = Nothing
End Sub
The first run it works as it should. The second time it runs everything works except formatting and filling the table. As far as I can trace it, it looks like Set PropTbl does not work. Creating the table works. But the next lines are failing/skipped. When I close the Excel with this VBA and open it again, it again works fine for the first run. Second run fails again.
What I tried was to make the table and then Set PropTbl:
WordDoc.Tables.Add RangeCT, RoundUp(Recordcounter / 2, 0), 4
Set PropTbl = WordDoc.Tables(1)
This also gives the same behavior. It almost looks like something is kept in the memory while keeping running excel. But I don't know how to debug the memory while all VBA routines are executed and finished.
Does anybody know how to fix or debug this?
Really wierd, but the fault is not in the posted code
This does work for the first run, but it fails the second time:
With PropTbl.Borders
.LineStyle = Options.DefaultBorderLineStyle
.LineWidth = Options.DefaultBorderLineWidth
.Color = Options.DefaultBorderColor
End With
With PropTbl.Borders(wdBorderLeft)
.LineStyle = Options.DefaultBorderLineStyle
.LineWidth = Options.DefaultBorderLineWidth
.Color = Options.DefaultBorderColor
End With
With PropTbl.Borders(wdBorderBottom)
.LineStyle = Options.DefaultBorderLineStyle
.LineWidth = Options.DefaultBorderLineWidth
.Color = Options.DefaultBorderColor
End With
With PropTbl.Borders(wdBorderRight)
.LineStyle = Options.DefaultBorderLineStyle
.LineWidth = Options.DefaultBorderLineWidth
.Color = Options.DefaultBorderColor
End With
With PropTbl.Borders(wdBorderVertical)
.LineStyle = Options.DefaultBorderLineStyle
.LineWidth = Options.DefaultBorderLineWidth
.Color = Options.DefaultBorderColor
End With
With PropTbl.Borders(wdBorderHorizontal)
.LineStyle = Options.DefaultBorderLineStyle
.LineWidth = Options.DefaultBorderLineWidth
.Color = Options.DefaultBorderColor
End With
fix was simple:
PropTbl.Borders.Enable = True
Gives the same result. Wierd thing was that it just fails with no error. The only hint I got was from a hover tip over the Options.DefaultBorderLineStyle which gives a hint that the servercomputer was not reachable...?
Anyway, it is solved.
I have the following vba code:
Dim targetChart As Chart
Dim labelRange As Range
Set targetChart = Worksheets("Graph").ChartObjects("Chart 2").Chart
Set labelRange = Worksheets("Graph").Range("H3", "H" & lastrow)
With targetChart.SeriesCollection(4)
.ApplyDataLabels
With .DataLabels
.Format.AutoShapeType = msoShapeRoundedRectangle
.Format.TextFrame2.TextRange.InsertChartField msoChartFieldRange, labelRange.Address(External:=True), 0
.ShowCategoryName = False
.ShowRange = True
.ShowSeriesName = False
.ShowValue = False
End With
End With
I want to format my data labels as rounded rectangles, but when I run the macro the .Format.AutoShapeType = msoShapeRoundedRectangle seems to not execute. When I step through the macro it doesn't throw an error so I am not sure what I am doing wrong. Everything else within the with statement works as intended.
The reason I have .ShowValue = False is because I am setting the data label values from a range.
Try this:
targetChart.FullSeriesCollection(1).ApplyDataLabels
With targetChart.FullSeriesCollection(1).DataLabels
.ShowRange = True
.ShowValue = False
.Format.AutoShapeType = msoShapeRoundedRectangle
.Format.TextFrame2.TextRange.InsertChartField msoChartFieldRange, labelRange.Address(External:=True), 0
.Format.Fill.Visible = msoTrue
.Format.Fill.ForeColor.ObjectThemeColor = msoThemeColorAccent2
.Format.Fill.ForeColor.TintAndShade = 0.5
.Format.Fill.ForeColor.Brightness = 0
.Format.Fill.Solid
End With
In Excel's Help it says that both DataLabels.Format (the entire DataLabels collection) and DataLabel.Format (a single DataLabel) are read-only. Maybe what you're trying can't be done.
I have an Access 2010 application where I run a SQL query and output the results to Excel. I'm using the Excel subtotal command to create subtotals. That works fine, but on the total rows only the text ("XXX Count") is bold and the values are not bold. Our client would like the entire row bold. I've tried a couple ways without success. How do I do the entire row in the subtotals?
So here is what I currently have:
This is correct except I need all of row 5, 8, 16, and 17 bold like this:
Here is my code to create the Excel file from Access (this all works except for the bold issues):
Public Sub ExportToExcel(query)
Dim appXL As Object
Dim wbk As Object
Dim wksNew As Object
Set appXL = CreateObject("Excel.Application")
Set wbk = appXL.Workbooks.Add
Set wksNew = wbk.Worksheets("Sheet1")
Dim cn As ADODB.Connection
Dim rs As ADODB.Recordset
Set appXL = CreateObject("Excel.Application")
appXL.Visible = True
Set wbk = appXL.Workbooks.Add
Set wksNew = wbk.Worksheets(1)
Set cn = CurrentProject.AccessConnection
Set rs = New ADODB.Recordset
With rs
Set .ActiveConnection = cn
.Source = query
.Open
End With
With rs
'Put recordset into new wks
wksNew.Cells(2, 1).CopyFromRecordset rs
'And add headers
Dim i As Long
For i = 0 To .Fields.Count - 1
wksNew.Cells(1, i + 1).Value = .Fields(i).Name
wksNew.Cells(1, i + 1).Font.Bold = True
wksNew.Cells(1, i + 1).HorizontalAlignment = xlCenter
Next i
'Now, while the recordset is available...
'The recordset has .fields.count fields
'Subtotals are wanted from field 7 to the end
If .Fields.Count > 13 Then
ReDim ary(14 To .Fields.Count - 1)
For i = LBound(ary) To UBound(ary)
ary(i) = i
Next i
wksNew.Cells(1, 1).CurrentRegion.SubTotal GroupBy:=1, _
TotalList:=ary, Replace:=True, PageBreaks:=False, SummaryBelowData:=True
End If
.Close
End With
End Sub
I tried this code based on this website:
Dim rCell As Range
wksNew.Columns("A:A").Select
Dim rCell As Range
For Each rCell In Selection
If Right(rCell.Value, 5) = "Count" Then
Rows(rCell.Row).Interior.ColorIndex = 36
End If
Next
but it returned a "Method or data member not found" error on the item rCell.Value.
I also tried it like this:
Dim rCell As Range
wksNew.Columns("A:A").Select
For Each rCell In Selection
If Right(rCell, 5) = "Count" Then
Selection.Font.Bold = True
End If
Next
But I got the error "ActiveX component can't create object" on the For Each line.
How do I bold the entire row for the subtotals?
You're getting an error because Access doesn't know what Selection is unless you tell it that it's connected to your Excel instance.
For Each rCell In Selection
However, don't need to select anything, or check the whole column:
Dim rCell As Range
For Each rCell In wksNew.UsedRange.Columns(1).Cells
If Right(rCell, 5) = "Count" Then
rCell.Font.Bold = True
End If
Next
Have you tried a Pivot Table?? It is easier to manage format or layout and you don't have to change too much your code because you just put your RecordSet in a PivotTableCache like the second example in this.
Rather than looping, I'd suggest collapsing the outline and formatting the visible cells:
with wksNew.Cells(1, 1).CurrentRegion
.Outlinelevel = 2
.specialcells(12).Font.Bold = True
.Outlinelevel = 3
End With
Thanks for all the suggestions. No one posted a solution that worked entirely, so here's what I ended up using:
Dim c As Object
For Each c In wksNew.Range("A1:A500")
If c.Value Like "*Total" Then
c.Offset(0, 13).Font.Bold = True
c.Offset(0, 14).Font.Bold = True
c.Offset(0, 15).Font.Bold = True
End If
Next
The only thing that concerns me is that I'm assuming this only has 500 rows. I couldn't find a way to find the number of rows and have it search only those. If I included the whole column, it took a couple minutes to complete the loop which I didn't think the client would like. Any suggestions on how to find the last row?
I would
Display level 2 of the outline, all the subtotals
Select the whole area
Use GoTo Special to select only visible cells
Apply the formatting
Change the header row formatting if it should be different
Display all the levels again (level 3)
This code demonstrates:
Sub Macro4()
Application.ScreenUpdating = False
ActiveSheet.Outline.ShowLevels RowLevels:=2
Range("A1").CurrentRegion.SpecialCells(xlCellTypeVisible).Font.Bold = True
'change the header row if necessary
Range(Range("A1"), Range("A1").End(xlToRight)).Font.Italic = True
ActiveSheet.Outline.ShowLevels RowLevels:=3
End Sub