PDA

View Full Version : Run-time error ‘-2147467259 (80004005)’



Daxton A.
11-01-2018, 03:51 AM
I have a worksheet that databases at the bottom of the worksheet by pulling all the info from the worksheet and puts each cell on the same row.
On my sheet I have the ability to select 1 of 7 options and click a button, a macro draws a circle around the active cell and bolds the font
of it. Now, when I db the worksheet, the circles get copied and stretched. So then I eliminated the circles because the text is also bold. I also
have a button that pulls all my cells from the database and puts them back onto the worksheet. I am redrawing the circles around the cell if
the
font.bold = true

The macro will run just one time and every time after that, it slings the error:

Run-time error ‘-2147467259 (80004005)’

I learned about this error a little but none of the solutions seemed to be related to my code:

Here is a copy of my workbook...

Paul_Hossler
11-01-2018, 07:02 AM
Form Controls (such as your DropDown70) are shapes, but you can't .Select them


At the right place(s) in your macro(s) try adding a test (in bold below) and bypassing at least the .Select




For iShapes = ActiveSheet.Shapes.Count To 1 Step -1
With ActiveSheet.Shapes(iShapes)

'MsgBox (ActiveSheet.Shapes(iShapes).TopLeftCell.Address)

If .Type <> msoFormControl Then




In general it's not necessary to .Select something, in oder to act on it

Daxton A.
11-01-2018, 10:41 AM
That is a form of debugging/learning used while I step through the code to help visually while trying to select the correct location.








Form Controls (such as your DropDown70) are shapes, but you can't .Select them


At the right place(s) in your macro(s) try adding a test (in bold below) and bypassing at least the .Select




For iShapes = ActiveSheet.Shapes.Count To 1 Step -1
With ActiveSheet.Shapes(iShapes)

'MsgBox (ActiveSheet.Shapes(iShapes).TopLeftCell.Address)

If .Type <> msoFormControl Then




In general it's not necessary to .Select something, in oder to act on it

Daxton A.
11-02-2018, 01:16 AM
Ok, it seemed to work but I don't know how to use it :think:



For Each s In Worksheets(1).Shapes
If s.Type = msoFormControl Then
If s.FormControlType = xlCheckBox Then _
s.ControlFormat.Value = False
End If
Next


I found this code on the Microsoft Help Webpage, but not sure how I will get the address to logically check
for "RL" "LL" etc.

Paul_Hossler
11-02-2018, 07:03 AM
Here's just one fragment of the macros

Just test the .Type of the Shape and only do the rest if it's NOT a form control





'******************************************
' Clearing Circles
'******************************************
For iShapes = ActiveSheet.Shapes.Count To 1 Step -1
With ActiveSheet.Shapes(iShapes)
If .Type <> msoFormControl Then ' <<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
'MsgBox (ActiveSheet.Shapes(iShapes).TopLeftCell.Address)
ActiveSheet.Shapes(iShapes).Select
Range(ActiveSheet.Shapes(iShapes).TopLeftCell.Address).Select
ActiveCell.Offset(1, 1).Select
If ActiveCell.Text = "RL" Then
ActiveCell.Font.Bold = True
End If
If ActiveCell.Text = "LL" Then
ActiveCell.Font.Bold = True
End If
If ActiveCell.Text = "RL/RS" Then
ActiveCell.Font.Bold = True
End If
If ActiveCell.Text = "RL/LS" Then
ActiveCell.Font.Bold = True
End If
If ActiveCell.Text = "LL/LS" Then
ActiveCell.Font.Bold = True
End If
If ActiveCell.Text = "LL/RS" Then
ActiveCell.Font.Bold = True
End If
If ActiveCell.Text = "CL" Then
ActiveCell.Font.Bold = True
End If
End If ' <<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
End With
Next iShapes

Paul_Hossler
11-02-2018, 07:07 AM
Instead of messing with circles, you could use the DoubleClick event to add/remove cell borders

Because you have other borders in adjacent cells, the Add/Remove borders has to have RLTB options





Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Dim R As Range

Set R = Target.Cells(1, 1)

Select Case R.Address
Case "$K$6"
Call RemoveBorders(Range("K7"))
Call AddBorders(R, False)
Case "$K$7"
Call RemoveBorders(Range("K6"), False)
Call AddBorders(R)
Case "$U$6"
Call RemoveBorders(Range("U7"))
Call AddBorders(R)
Case "$U$7"
Call RemoveBorders(Range("U6"), False)
Call AddBorders(R)
End Select

End Sub






Option Explicit
Sub AddBorders(Rng As Range, Optional T As Boolean = True, Optional B As Boolean = True, Optional L As Boolean = True, Optional R As Boolean = True)
With Rng
.Borders(xlDiagonalDown).LineStyle = xlNone
.Borders(xlDiagonalUp).LineStyle = xlNone
If T Then
With .Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlMedium
End With
End If
If B Then
With .Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlMedium
End With
End If
If L Then
With .Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlMedium
End With
End If
If R Then
With .Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlMedium
End With
End If
End With
End Sub

Sub RemoveBorders(Rng As Range, Optional T As Boolean = True, Optional B As Boolean = True, Optional L As Boolean = True, Optional R As Boolean = True)
With Rng
.Borders(xlInsideVertical).LineStyle = xlNone
.Borders(xlInsideHorizontal).LineStyle = xlNone
.Borders(xlDiagonalDown).LineStyle = xlNone
.Borders(xlDiagonalUp).LineStyle = xlNone
If L Then .Borders(xlEdgeLeft).LineStyle = xlNone
If T Then .Borders(xlEdgeTop).LineStyle = xlNone
If B Then .Borders(xlEdgeBottom).LineStyle = xlNone
If R Then .Borders(xlEdgeRight).LineStyle = xlNone
.Borders(xlInsideVertical).LineStyle = xlNone
.Borders(xlInsideHorizontal).LineStyle = xlNone
End With
End Sub

Daxton A.
11-04-2018, 06:36 AM
Thanks for the help everyone. I feel responsible to give the other coders name because we both created the spreadsheet. Jamie M. is a great friend and coder. I appreciate the help everyone.

Daxton A.
11-19-2018, 03:31 AM
https://docs.microsoft.com/en-us/office/vba/api/excel.shapes.range