Excel VBA kopier X antal ark fra 2 filer

"Slutteligt, og evt i en seperat makro skal et outlook vindue åbnes hvor de nye filer er vedhæftede"

Er der ikke kun tale om en ny fil?

-

Hvis du opbygger en illustrativ model af masterfiler og "ny fil" så skal jeg prøve at udarbejde koden. Denne vil jeg så placere i en "systemfil", der automatisk åbner de to masterfiler - kopiere ark til en ny fil - lukker masterfilerne - kalder outlook og sender den nye fil.

Du er altså velkommen til at sende en model - @-adresse under min profil.

Jo der er kun tale om 1 ny fil. Det var en uklar formulering, da jeg mente at det evt. kunne skrive som et separat VBA modul i samme projektmappe.

Smart forslag med at have en "systemfil" hvorfra filudsplitning kunne foregå fra.
Masterfilerne består af en række ark. Typisk er 1 ark med data og et ark 2 med data og grafer. Ark 2 har en del referencer til ark 1. For at sikre at alt kommer med, vil det derfor være smartest at kopiere hele arket over som det er i masterfilerne.

Masterfilerne hedder:
K-data.xlsm
F-data.xlsm

Den nye fil skal hedde: " & "TPM " & FilNavn & Mdr & ".xlsm
hvor:
FilNavn = Range("A2").Value
Mdr = Range("R2").Value

De "nye" filer med ark fra de 2 masterark kan se ud som følger:
eksempel 1:

Arknavn: BHN (kilde: K-data.xlsm
Arknavn: BHN Analyse (kilde: K-data.xlsm)

Eksempel 2:
Arknavn: BBB (kilde: K-data.xlsm
Arknavn: BBB Analyse (kilde: K-data.xlsm
Arknavn: BRO (kilde: F-data.xlsm
Arknavn: BRO Analyse (kilde: F-data.xlsm
m.fl. ark

Koden skal derfor være fleksibel i forhold til at jeg i koden selv kan sætte op hvilke filer og fra hvor som skal over i den "nye fil".

Det kunne med fordel laves sådan at først hentes alle ark fra K-data, hvorefter den lukkes ned. Derefter hentes alle ark fra F-data.

Grunden hertil er at K-data fylder ca. 61 mb og F-data fylder ca. 86 mb

Slutteligt evt. i et seperat modul kunne e-mail funktionen være?

Jeg ved ikke om det besvarer de manglede informationer du mangler, eller om de skal være mere præcise/formuleres på en anden måde?

Spørgsmål:

"Koden skal derfor være fleksibel i forhold til at jeg i koden selv kan sætte op hvilke filer og fra hvor som skal over i den "nye fil".

Filnavne & sti - eller?

--

Alt andet lige ville det have været nemmere, hvis jeg kunne få en model. som jeg nævnte. Altså med repræsentation af filerne.

Endnu et spørgsmål:

FilNavn = Range("A2").Value
Mdr = Range("R2").Value

Fra hvilken fil/ark?

Fleksibel i forhold til at jeg i koden kan angive hvilke ark i de 2 masterfiler jeg vil have over i den nye fil.

Jeg kan godt opsætte en model i excel og sende til dig? En model er det hvordan selve master arkene ser ud?

FilNavn = Range("A2").Value
Mdr = Range("R2").Value


Værdierne herfra er placeret i det første ark som skal kopieres fra masterfilerne. F.eks. ift. tidligere eksempel så står værdierne heri i arkene BHN og BBB

Tror vi stopper her - måske kommer der en forbi...

Måske lettere hvis jeg sender dig en model over filerne?

Ok -

så er det afsendt :)

VBA-kode i Userform1:

Rem Reference til Microsoft Outlook xx. Object Library er sat
Rem =========================================================
Const masterSti = "C:\Users\peter\Desktop\Zany_945248\"                    'Tilpasses
Const resultatSti = "C:\Users\peter\Desktop\Zany_945248\ResultatFiler\"      '-- " --

Dim Kdata As Workbook, Fdata As Workbook
Const KmasterNavn = "K-data.xlsm"
Const FmasterNavn = "F-data.xlsm"

Const resultatDummyNavn = "Resultat.xlsm"
Dim ResultatObj As Workbook, resultatFilNavn As String

Const modtagerMail = "xx@xxx-it.dk"                                  'Tilpasses
Private Sub CommandButton1_Click()                  'Ok-knap
On Error GoTo fejl
    With ResultatObj
        kopierFraMaster Kdata, Me.Lb_KarkNavne
        kopierFraMaster Fdata, Me.Lb_FarkNavne
       
        If .Sheets.Count > 1 Then
            Application.DisplayAlerts = False
            .Sheets("xxx").Delete
       
            .SaveAs Filename:=resultatSti & resultatFilNavn
        End If
    End With
   
Rem overfør resultatfilnavn til arket
    ThisWorkbook.ActiveSheet.Range("A1") = resultatSti
    ThisWorkbook.ActiveSheet.Range("A2") = resultatFilNavn
   
    lukAlleObjekter
   
    Exit Sub
   
fejl:
    MsgBox "Fejl erkendt"
    Stop
    Resume Next                'til test

    lukAlleObjekter
End Sub
Private Sub userform_terminate()
    lukAlleObjekter
End Sub
Private Sub lukAlleObjekter()
    lukObjekt Kdata
    lukObjekt Fdata
    lukObjekt ResultatObj
   
    Unload UserForm1
End Sub
Private Sub kopierFraMaster(mobj As Workbook, listeObj As Object)
Dim f As Byte, antalArk As Byte
    For f = 0 To listeObj.ListCount - 1
       
        antalArk = ResultatObj.Sheets.Count
       
        If listeObj.Selected(f) = True Then
            arknavn = listeObj.List(f)
                     
            mobj.Sheets(arknavn).Copy after:=ResultatObj.Sheets(antalArk)
        End If
    Next f
End Sub
Private Sub UserForm_activate()
    Application.Cursor = xlDefault
    visDataFraMaster
End Sub
Private Sub visDataFraMaster()
    Application.ScreenUpdating = False
   
    Application.Cursor = xlWait
    Me.Frame1.Enabled = True
    fraMaster Kdata, KmasterNavn, Me.Lab_Kfilnavn, Me.Lab_Kmåned, Me.Lb_KarkNavne
   
    Me.Frame2.Enabled = True
    fraMaster Fdata, FmasterNavn, Me.Lab_FfilNavn, Me.Lab_Fmåned, Me.Lb_FarkNavne
    Application.Cursor = xlDefault
   
Rem opret resultatfil
    resultatFilNavn = "TPM " & Me.Lab_Kfilnavn & " " & Me.Lab_Kmåned
    Set ResultatObj = Workbooks.Open(masterSti + resultatDummyNavn)
       
    Me.CommandButton1.Enabled = True
End Sub
Private Sub fraMaster(mobj As Workbook, masterfilNavn As String, filNavnObj As Object, månedObj As Object, listeObj As Object)
Dim ark As Worksheet

On Error GoTo lukFilObj
   
    Set mobj = Workbooks.Open(masterSti + masterfilNavn)
    filNavnObj = mobj.ActiveSheet.Range("A2")
    månedObj = mobj.ActiveSheet.Range("R2")
       
Rem Vis arknavne, der ikke er rent numeriske
    listeObj.Clear
   
    For Each ark In mobj.Sheets
        If IsNumeric(ark.Name) = False Then
            listeObj.AddItem ark.Name
        End If
    Next ark
    Exit Sub
   
lukFilObj:
    MsgBox "Fejl erkendt"
    Resume Next

    lukObjekt mobj
    Stop
End Sub
Private Sub lukObjekt(mobj As Workbook)
On Error Resume Next
    Application.Cursor = xlDefault

    mobj.Close savechanges:=False
    Set mobj = Nothing
End Sub
Public Sub emailSendes()
    SendResultatFil modtagerMail, ThisWorkbook.ActiveSheet.Range("A2"), ThisWorkbook.ActiveSheet.Range("A1")
End Sub
Public Sub SendResultatFil(modtager, emne, ResultatFilSti)
Dim mailApp, Namespace, indbakke, nyMail, nyAtt
    Set mailApp = CreateObject("Outlook.Application")

    Set nyMail = mailApp.CreateItem(olMailItem)
    Set nymod = nyMail.Recipients
    nymod.Add modtager
    nyMail.Subject = emne
   
    Set nyAtt = nyMail.Attachments
    nyAtt.Add ResultatFilSti & emne + ".xlsm"
   
    nyMail.Display
    nyMail.send
End Sub