Erro em tempo de execução '2147221037 (800401d3)
Enviado: 07 Mar 2019 às 09:01
Olá a todos!
Tenho uma planilha feita já algum tempo (anos) , só que ultimamente está dando esse erro de execução "Erro em tempo de execução '2147221037 (800401d3) - ObjetodeDados:ObterTexto Os dados na Área de Transferencia são invalidos.
O erro fica nessa parte.
Já busquei algo semelhante e fóruns e não obtive exito.
Tenho uma planilha feita já algum tempo (anos) , só que ultimamente está dando esse erro de execução "Erro em tempo de execução '2147221037 (800401d3) - ObjetodeDados:ObterTexto Os dados na Área de Transferencia são invalidos.
Código: Selecionar todos
Private Sub CommandButton1_Click()
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Run "inventar"
Run "inventar2"
Application.ScreenUpdating = False
Application.CutCopyMode = False
'copiar dados e colar
Dim MyDataObj As DataObject
Dim i As Integer
Dim j As Integer
Set MyDataObj = New DataObject
Sheets("cadastro medição").Select
'Laço de linhas
For i = 6 To 35
'Laço de colunas
For j = 31 To 44
'Trata as exceções que são as colunas "AF" (32) e
'"AP" (42)
If j <> 32 And j <> 42 Then
TextBox1.Value = Cells(i, j)
TextBox1.Text = Cells(i, j).Value
MyDataObj.SetText TextBox1
MyDataObj.PutInClipboard
MyDataObj.GetFromClipboard
Cells(i, j - 17) = MyDataObj.GetText()
MyDataObj.SetText ""
MyDataObj.PutInClipboard
End If
Next
Next
'---------------
Sheets("equipamentos").Select
ActiveSheet.Unprotect Password:="123"
ActiveSheet.Range("$A$1:$V$2").AutoFilter Field:=16
ActiveSheet.Range("$A$1:$V$2").AutoFilter Field:=15
ActiveSheet.Range("$A$1:$V$2").AutoFilter Field:=14
ActiveSheet.Range("$A$1:$V$2").AutoFilter Field:=13
ActiveSheet.Range("$A$1:$V$2").AutoFilter Field:=12
ActiveSheet.Range("$A$1:$V$2").AutoFilter Field:=11
ActiveSheet.Range("$A$1:$V$2").AutoFilter Field:=10
ActiveSheet.Range("$A$1:$V$2").AutoFilter Field:=9
ActiveSheet.Range("$A$1:$V$2").AutoFilter Field:=8
ActiveSheet.Range("$A$1:$V$2").AutoFilter Field:=7
ActiveSheet.Range("$A$1:$V$2").AutoFilter Field:=6
ActiveSheet.Range("$A$1:$V$2").AutoFilter Field:=5
ActiveSheet.Range("$A$1:$V$2").AutoFilter Field:=4
ActiveSheet.Range("$A$1:$V$2").AutoFilter Field:=3
ActiveSheet.Range("$A$1:$V$2").AutoFilter Field:=2
ActiveSheet.Range("$A$1:$V$2").AutoFilter Field:=1
Sheets("cadastro medição").Select
'tirando a formula e transformando em texto
Range("N5").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("R5").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
'continua
Range("A4").Select
Selection.End(xlDown).Select
Selection.End(xlDown).Select
Selection.End(xlUp).Select
Selection.End(xlToRight).Select
Selection.End(xlToRight).Select
Selection.End(xlToRight).Select
Range(Selection, Selection.End(xlUp)).Select
Range(Selection, Selection.End(xlToLeft)).Select
Range(Selection, Selection.End(xlToLeft)).Select
Selection.Copy
'NOVO
Sheets("equipamentos").Select
Range("A1").Select
Selection.End(xlDown).Select
Selection.End(xlDown).Select
Selection.End(xlUp).Select
Selection.Insert Shift:=xlDown
Application.CutCopyMode = False
ActiveSheet.Protect Password:="123", DrawingObjects:=True, Contents:=True, Scenarios:=True, AllowFiltering:=True
Sheets("cadastro medição").Select
'voltando as formulas
Range("N5").Select
Application.CutCopyMode = False
ActiveCell.FormulaR1C1 = "=R[1]C"
Range("R5").Select
ActiveCell.FormulaR1C1 = _
"=R[1]C[-4]&"" - cadastrado: ""&TEXT(TODAY(),""dd/mm/aa"")&"" as ""&TEXT(NOW(),""hh:mm"")"
Range("A4").Select
Sheets("equipamentos").Select
Unload Me
Application.Calculation = xlCalculationAutomatic
MsgBox "MEDIÇÕES CADASTRADAS NO BANCO DE DADOS"
Application.CutCopyMode = True
Application.ScreenUpdating = True
End Sub
O erro fica nessa parte.
Código: Selecionar todos
Dim MyDataObj As DataObject
Dim i As Integer
Dim j As Integer
Set MyDataObj = New DataObject
Sheets("cadastro medição").Select
'Laço de linhas
For i = 6 To 35
'Laço de colunas
For j = 31 To 44
'Trata as exceções que são as colunas "AF" (32) e
'"AP" (42)
If j <> 32 And j <> 42 Then
TextBox1.Value = Cells(i, j)
TextBox1.Text = Cells(i, j).Value
MyDataObj.SetText TextBox1
MyDataObj.PutInClipboard
MyDataObj.GetFromClipboard
Cells(i, j - 17) = MyDataObj.GetText() ' NORMALMENTE O ERRO FICA NESSA LINHA
MyDataObj.SetText ""
MyDataObj.PutInClipboard
End If
Next
Next
'---------------
Já busquei algo semelhante e fóruns e não obtive exito.