Este fórum está sendo desativado

[jmarcelosp]

Olá

Tentando reproduzir no excel o que foi explicado em um video para automatizar a extração de informações de outras planilhas,( planilha Aula, importar dados das planilhas "Campus"),
E não funcionou como explicado, quando dou F8 no vba, executa bem até a abrir outras planilha, mas a busca das informações não funcionou, e também adicionei um botão para importar e está dando Erro "em tempo de execução '424'"


Sub Importar_Dados()

On Error GoTo Erro

Application.ScreenUpdating = False


Dim Guia As Object
Dim Planilha As Workbook
Dim EnderecoPlan As String
Dim Coluna As Double, Linha As Double, ColDestino As Double
Dim ColInicial As Double, ColFinal As Double, LinOrigem As Double


EnderecoPlan = Application.GetOpenFilename(FileFilter:="file, *.xls*")


If EnderecoPlan <> Empty And EnderecoPlan <> "Falso" Then
Set Planilha = Application.Workbooks.Open(EnderecoPlan)
Else
Application.ScreenUpdating = True
Exit Sub
End If

Set Guia = Planilha.Worksheets(1)

Windows(Planilha.Name).Visible = False

Coluna = 1
Lin = 1


Inicio:
Do

Linha = Linha + 1

If Guia.Cells(Linha, Coluna).Value <> Empty Then
LinOrigem = Linha
ColInicial = Coluna


Do
Coluna = Coluna + 1
Loop Until Guia.Cells(Linha, Coluna).Value = Empty

ColFinal = Coluna - 1
Exit Do
End If

If Coluna = 100 Then
MsgBox "Não encontrado cabeçalho!", vbExclamation, "IMPORTAR"
Exit Sub
End If




Loop Until Linha = 10

If LinOrigem = Empty Then
Coluna = Coluna + 1
Linha = 1
GoTo Inicio:

End If

Coluna = ColIncial
ColDestino = 2
Linha = WorksheetFunction.CountA(Planilha1.Range("B:B")) + 3

With Planilha1

Do
LinOrigem = LinOrigem + 1

For Coluna = ColInicial To ColFinal
.Cells(Linha, ColDestino).Value = Guia.Cells(LinOrigem, Coluna).Value
ColDestino = ColDestino + 1
Next Coluna

ColDestino = 2
Linha = Linha + 1


Loop Until Guia.Cells(LinOrigem, ColInicial).Value = Empty

End With

Windows(Planilha.Name).Visible = True

Application.DisplayAlerts = False
Windows(Planilha.Name).Close
Application.DisplayAlerts = True


Set Planiha = Nothing
Set Guia = Nothing

Application.ScreenUpdating = True


Exit Sub
Erro:
MsgBox "Erro!", vbCritical, "IMPORTAR"

End Sub



Do botão

Private Sub CommandButton1_Click()
Módulo2.Importar_Dados
End Sub


Grato