1. Este site usa cookies. Ao continuar a usar este site está a concordar com o nosso uso de cookies. Saber Mais.

Ajuda: programação de macro VB em Excel

Discussão em 'Programação' iniciada por nickie, 29 de Março de 2013. (Respostas: 1; Visualizações: 898)

  1. nickie

    nickie Power Member

    Olá a todos,

    Queria pedir a vossa ajuda para um problema que tenho em mãos. Já andei a tentar resolver, mas não consigo arranjar solução.
    O que se passa é o seguinte:
    - tenho mais de duas centenas de ficheiros (xlsm) num diretório os quais são constituidos por 2 worksheets: uma com uma macro (escrita por uma empresa) e outra com dados que essa macro extrai de uma base de dados. As folhas com dados estão com o nome sheet1.
    - devido à imensidão de ficheiros, queria criar uma macro em excel que fizesse o seguinte:
    . ler ficheiros que estão no diretório
    . abrir cada um dos ficheiros individualmente e sequencialmente
    . em cada um dos ficheiros copiar toda a sheet1 para um novo workbook
    . dar o nome do ficheiro original (que está com extensão xlsm) ao novo workbook e gravar como xlsx

    Alguém sabe como se pode programar isso em excel?

    Obrigado pela ajuda!
     
  2. fmf1966

    fmf1966 Power Member

    Tenta isto:

    Código:
     
    Public Sub GravarSheet1()
        Dim S As String, F As String, X As String
        Dim Xl As Excel.Application
        Dim Wx As Workbook, Sh As Worksheet
        
        F = GetFolder()
        
        If F = "" Then Exit Sub
        F = F & "\"
        Set Xl = CreateObject("Excel.Application")
        Xl.DisplayAlerts = False
        Xl.EnableEvents = False
        
        S = Dir(F & "*.xlsm")
        Do Until S = ""
            Set Wx = Xl.Workbooks.Open(F & S)
            X = F & Left(S, Len(S) - 5)
            For Each Sh In Wx.Sheets
                If Sh.Name <> "sheet1 " Then
                    Sh.Delete
                End If
            Next
            Wx.SaveAs X, xlWorkbookDefault
            Wx.Close
            S = Dir()
        Loop
        
        Xl.EnableEvents = True
        Xl.DisplayAlerts = True
        Xl.Quit
        MsgBox "Terminado"
    End Sub
    
    Public Function GetFolder() As String
        Dim objFSO As Object
        Dim objShell As Object
        Dim objFolder As Object
        Dim objFolderItem As Object
        
        Set objFSO = CreateObject("Scripting.FileSystemObject")
        Set objShell = CreateObject("Shell.Application")
        Set objFolder = objShell.BrowseForFolder(0, "", 0)
        If objFolder Is Nothing Then
            GetFolder = ""
        Else
            Set objFolderItem = objFolder.Self
            GetFolder = objFolderItem.Path
        End If
    End Function
     
    
    Por não saber se tu tens conhecimentos de VBA Excel, não coloquei a explicação.
    Se tiveres duvidas, pergunta.
     

Partilhar esta Página