VBA - Copy and Paste Data Base into an existing Sheet
Hello everyone
I tried writing the following code:
(It was working fine, but whenever I moved the files to another location, the code doesn't work)
Thank you all in advance. Sorry for the messy code. It's my first attempt on VBA.
Code:
'UnificarPlanilhas Macro
Sub lsUnificarPlanilhas()
Application.ScreenUpdating = False
' Apagar_Base Macro
Sheets("Dashboard").Select
Sheets("Base").Visible = True
Sheets("Base").Select
Range("B2:T5000").Select
Selection.ClearContents
' Fim Apagar_Base Macro
On Error GoTo Sair
Dim lUltimaColunaAtiva As Long
Dim lUltimaLinhaAtiva As Long
Dim lRng As Range
Dim sPath As String
Dim fName As String
Dim lNomeWB As String
Dim lIPlan As Integer
Dim lUltimaLinhaPlanDestino As Range
PlanilhaDestino = ThisWorkbook.Name
sPath = Localizar_Caminho
sName = Dir(sPath & "\*.xl*")
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
Do While sName <> ""
fName = sPath & "" & sName
Workbooks.Open Filename:=fName, UpdateLinks:=False
lNomeWB = ActiveWorkbook.Name
For Each vPlan In Sheets
vPlan.Visible = True
Next
Sheets("Base Mascara").Select
Range("B2:T350").Select
Selection.Copy
Workbooks(PlanilhaDestino).Worksheets("Base").Activate
Range("B2").Select
Selection.End(xlDown).Select
Selection.End(xlDown).Select
Selection.End(xlUp).Select
ActiveCell.Offset(1, 0).Select
ActiveCell.PasteSpecial xlPasteValues
Range("A1").Select
Application.CutCopyMode = False
Workbooks(lNomeWB).Close SaveChanges:=False
sName = Dir()
Loop
Sair:
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Range("b4").Select
Selection.End(xlDown).Select
Sheets("Base").Select
ActiveWindow.SelectedSheets.Visible = False
' Esconder Aba Ajustado
Sheets("AJUSTADO").Select
ActiveWindow.SelectedSheets.Visible = False
' Atualizar_Tabela_Dinamica Macro
ActiveWorkbook.RefreshAll
' FIM Atualizar_Tabela_Dinamica Macro
MsgBox "Planilhas Unificadas e Tabela Atualizada!"
Application.ScreenUpdating = True
End Sub
Function gfLetraColuna(ByVal rng As Range) As String
Dim lTexto() As String
lTexto = Split(rng.Address, "$")
gfLetraColuna = lTexto(1)
End Function
Public Function Localizar_Caminho() As String
Dim strCaminho As String
With Application.FileDialog(msoFileDialogFolderPicker)
'Permitir mais de uma pasta
.AllowMultiSelect = False
'Mostrar janela
.Show
If .SelectedItems.Count > 0 Then
strCaminho = .SelectedItems(1)
End If
End With
'Atribuir caminho a variável
Localizar_Caminho = strCaminho
End Function
