Actualizar apena código sem alterar folhas

[Ridelight]

Boa tarde, há alguma forma de actualizar apenas o código de um .xlsm sem perder dados nas folhas de dados?

[tiago.f]

Olá,

Assumo que esta pergunta seja porque, como eu, tens uma "aplicação" feita em excel e queres fazer um upgrade sem perder dados.

Eu faço assim (se alguém souber de um processo mais simple era excelente):

Estrutura base da minha "aplicação":

• Folha(s) de input/UI.
  
  • Folha toda bonita onde o utilizador adiciona/modifica/apaga informação
    
  • Cada grupo lógico de inputs tem um nome (named range) do tipo REF_*
    

  [*]Folha de trabalho.

  • Contem formulas para os dados na(s) folha(s) de input/UI. Exemplo (A1) = Input!A1
    
  • Os dados estão agrupados pelos mesmo grupos lógicos da folha de input
    
  • Não tem named ranges
    

  [*]Folha de Base de Dados

  • Contém a minha "BD"
    
  • Quando o utilizador grava o ficheiro, corro VBA para copiar valores (tudo de uma vez), da folha de trabalho para a folha de BD.
    
  • Esta folha de BD tem named ranges do tipo DB_*
    
  • Quando fazemos a cópia os dados da folha de trabalho "caem" exactamente no mesmo sitio/celulas na folha de BD. E porque copiamos só os valores, não perdemos os named ranges.
    

Processo de "upgrade"

Assumindo como nomes dos ficheiros:

- ficheiro "antigo": XPTO.xlsm

- ficheiro "novo": Template_v3.xlsm

A lógica é:

• o Template_v3.xlsm vai abrir o XPTO.xlsm, e copiar os dados da(s) folhas de BD (vê acima) do XPTO.xlsm para si.
  
• Depois, para cada named range chamado/começado por DB_ (e que agora tem os dados populados), vai copiar os dados de DB_x para REF_x. Desta maneira actualiza a folha de input/UI.
  
• Depois faz "save as" ao XPTO.xlsm e da-lhe outro nome - exemplo XPTO_backup.xlsm.
  
• Depois grava-se a si proprio com o nome original do ficheiro antigo.(XPTO.xlsm)
  

Se quiseres ver o código posso tentar extrair...

Espero não ter sido muito confuso.

Abraço

[Ridelight]

Sim exatamente, era mesmo isso, mas se podesses mostrar em código era mais fácil, obrigado.

[tiago.f]

Não posso enviar o ficheiro mas posso colocar o codigo do modulo que faz a maior parte do trabalho:

Sub CopyValues(ByRef from As Range, ByRef into As Range)
   'Dim rSrc As Range
   ''Dim rDst As Range
  '' Set rSrc = from
   'Set rDst = into.Resize(rSrc.Rows.Count, rSrc.Columns.Count)
   into.Resize(from.Rows.Count, from.Columns.Count) = from.Value

End Sub
Sub RestoreFromPreviousVersion()
' ask the user if he wants to import data from a previous version
' if this is the first time using the file
 On Error GoTo handleError

   On Error GoTo handleError

   If ThisWorkbook.Names("TOOL_INITIALIZED").RefersToRange.Value = 0 Then

    'ask the use rif he wants to import
    answer = MsgBox("Would you like to upgrade a previous version?", vbYesNo + vbQuestion, "Import data")

    If answer = vbYes Then
	    'he does. Do it!
	    ImportFromPreviousVersion
    Else
	    ThisWorkbook.Names("TOOL_INITIALIZED").RefersToRange.Value = 1
    End If


   End If

   Exit Sub

handleError:
   MsgBox Err.Description, vbCritical, "Error while importing"
   ThisWorkbook.Names("TOOL_INITIALIZED").RefersToRange.Value = 0



End Sub
Sub ValidateFile(ByRef oldWb As Workbook)

   If HasSheet(ThisWorkbook, "Project_Log") <> HasSheet(oldWb, "Project_Log") Then
    Err.Raise 520, "", "Cannot import data. Source is file is not upgradeble"
   End If

   'On Error GoTo handleError
   ' check if version is <= than this version
   If Not NameExists(oldWb, "TOOL_VERSION") Then
	 Err.Raise 520, "", "Cannot import data. Source file version too old."
   End If

   'check if DB sheet exists
   If Not HasSheet(oldWb, "DB") Then
    Err.Raise 520, "", "Cannot import data. Source file version too old."
   End If

   If oldWb.Names("TOOL_VERSION").RefersToRange.Value > ThisWorkbook.Names("TOOL_VERSION").RefersToRange.Value Then
    Err.Raise 600, "", "This file version (v" & ThisWorkbook.Names("TOOL_VERSION").RefersToRange.Value & _
	    ")is older than the one you are importing from (v" & oldWb.Names("TOOL_VERSION").RefersToRange.Value & _
	    ")." & vbNewLine & "Import stopped."

   End If



   Exit Sub

'handleError:
'	 Err.Raise 520, "", "Cannot import data. Source is file must be not usable."
End Sub
Function HasSheet(wb As Workbook, name As String) As Boolean
   For Each Sheet In wb.Sheets
    If Sheet.name = name Then
	    HasSheet = True
	    Exit Function
    End If
   Next Sheet
   HasSheet = False
End Function
Function NameExists(wb As Workbook, N As String) As Boolean
   Dim Test As name
   On Error Resume Next
   Set Test = wb.Names(N)
   NameExists = Err.Number = 0
End Function

Sub SaveToDB()
'
' SaveWork Macro
'
' This macro saves the content of the Work sheet into the DB
' Copies the values and not the formulas

   CopyValues ThisWorkbook.Sheets("Work").Range("A1:ZZ1000"), ThisWorkbook.Sheets("DB").Range("A1")

End Sub
Sub RestoreFromDB()
'
' RestoreFromDB Macro
'
' This Macro copies the below sections from the DB sheet into the user input sheets
   Sections = GetDBSections()

   For Each section In Sections
    CopyValues ThisWorkbook.Names("DB_" & section).RefersToRange, ThisWorkbook.Names("REF_" & section).RefersToRange
   Next
End Sub
Sub ImportFromPreviousVersion()
' ask the user to select the previous version file

   file = GetFileFromUser()

   If file <> "" Then
    ImportFromFile file
   Else
    Err.Raise 520, "", "You selected no file."
   End If
End Sub
Sub ImportFromFile(ByVal file As String)
   ' imports the DB sheet from 'file' into this workbook's DB sheet
  Dim oldWb As Workbook
   Dim checkedOut As Boolean

   checkedOut = False

   On Error GoTo handleError

   'check out if necessary
   If Workbooks.CanCheckOut(file) Then
    Workbooks.CheckOut file
    checkedOut = True
   End If

   Set oldWb = Workbooks.Open(Filename:=file, ReadOnly:=True)

   'check if the oldWb file is valid for importing
   ValidateFile oldWb

   ' copy the DB from the old version to this one
   Sections = GetDBSections()

   For Each section In Sections
    ' check if the oldWB has this named range. (could be a new one in thsi version)
    If NameExists(oldWb, "DB_" & section) Then
	    'copy from the "old" file into this one
	    CopyValues oldWb.Names("DB_" & section).RefersToRange, ThisWorkbook.Names("DB_" & section).RefersToRange
    End If
   Next

   RestoreFromDB

   Filename = oldWb.FullName
   shortName = oldWb.name

   ThisWorkbook.Names("TOOL_INITIALIZED").RefersToRange.Value = 1

   'save a backup and overwrite the old File (=upgrade it)
   If checkedOut Or oldWb.CanCheckIn Then
    'we can checkin so no point in saving a backup. Versioning will do that for us
    Application.DisplayAlerts = False
    oldWb.Close SaveChanges:=False
    Application.DisplayAlerts = True
    ThisWorkbook.SaveAs Filename:=Filename ', CreateBackup:=False

    'ThisWorkbook.CheckInWithVersion
    MsgBox "The file " & vbNewLine & "'" & shortName & "'" & vbNewLine & _
	    "is now updated to the latest version." & vbNewLine & _
	    "That file is currently opened and is the one you are seing now." & vbNewLine & vbNewLine & _
	    "Make sure you SAVE AND CHECK IN this file!!!"
   Else
    'save a backup
    pos = InStrRev(oldWb.FullName, ".")
    FullPath = Left(oldWb.FullName, pos - 1) & "_backup.xlsm"
    oldWb.SaveCopyAs FullPath
    oldWb.Close SaveChanges:=False
    Application.DisplayAlerts = False
    ThisWorkbook.SaveAs Filename
    Application.DisplayAlerts = True

    MsgBox "The file " & vbNewLine & "'" & shortName & "'" & vbNewLine & _
	    "is now updated to the latest version." & vbNewLine & _
	    "A backup has been created in the same folder." & vbNewLine & vbNewLine & _
	    "Make sure you SAVE THIS FILE !!!"
   End If

   Exit Sub

handleError:
   oldWb.Close SaveChanges:=False
   Err.Raise Err.Number, Err.Source, Err.Description

End Sub
Function GetFileFromUser() As String
   Dim fdgOpen As FileDialog
   Set fdgOpen = Application.FileDialog(msoFileDialogOpen)

   With fdgOpen
    .AllowMultiSelect = False
    .Title = "Please select the Weekly Project Report to import from..."
    .Filters.Clear
    .Filters.Add "Excel Files", "*.xlsx, *.xlsm"
    'fdgOpen.InitialFileName = "C:\MyDocuments\MyDir\"
    .Show
   End With

   If fdgOpen.SelectedItems.Count = 0 Then
    GetFileFromUser = ""
   ElseIf fdgOpen.SelectedItems.Count <> 1 Then
    Err.Raise 600, "", "Please select 1 file"
   Else
    GetFileFromUser = fdgOpen.SelectedItems(1)
   End If

End Function
Function GetDBSections() As Variant
   Dim col As New Collection

   ' Gets all the named ranges starting with "DB_"
   For Each Nm In ThisWorkbook.Names
    If InStr(1, Nm.name, "DB_") = 1 And InStr(1, Nm.name, "!") < 1 Then
	    col.Add Right(Nm.name, Len(Nm.name) - 3)
    End If
   Next

   GetDBSections = toArray(col)

   'GetDBSections = Array("Header_1", "Header_2", "Header_3", _
   '				    "Overall_1", "Overall_2", _
   '				    "Milestones_1", "Milestones_2", _
   '				    "Issues_1", "Issues_2", "Issues_3", _
   '				    "Activities_1", "Activities_2", "Activities_3")

End Function
Function toArray(col As Collection)
   Dim arr() As Variant
   ReDim arr(1 To col.Count) As Variant
   For i = 1 To col.Count
    arr(i) = col(i)
   Next
   toArray = arr
End Function

Depois no codigo do proprio workbook, para que execute quando salva:

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
   Application.ScreenUpdating = False
   'add code to save changes to DB sheet
   SaveToDB

   Application.ScreenUpdating = True
End Sub

e no workbook open:

Private Sub Workbook_Open()
   ' checks if this file has never been used and if yes
   ' prompts the user to import data from a previous version
   RestoreFromPreviousVersion
End Sub

[Ridelight]

Obrigado pela disponibilidade, vou ver se me entendo... ;oP