Avatar billede mr.9mm Nybegynder
16. april 2008 - 12:57 Der er 14 kommentarer og
1 løsning

gentagende indsættelse af data i xl fra vedhæftet fil i emails

I forbindelse med afslutningen på min kontor uddannelse, skal der laves en fagprøve. Til den fagprøve har jeg lavet et spørgeskema i xl, som jeg vil sende ud til 1000 mennesker.
Når de har udfyldt skemaet og trykker på en afslut knap, bliver det udfyldte xl skema automatisk sendt tilbage til mig som en vedhæftet fil i en e-mail.

nu vil jeg så gerne samle alle svarne sammen i et xl regneark.
Og hvordan gør jeg så lige det smartest? Kom endelig med nogle bud, for jeg er lidt på bar bund her.

Jeg bruger Outlook som mail program og har oprette en regel, så de alle havner i samme mappe.

det jeg skal bruge er: afsenders mail adresse og fra den vedhæftede xl fil, skal jeg bruge svarne som står i ark2 fra B17 til og med B29

Hvis der er nogen som kan hjælpe, ville jeg være lykkelig.

Venlig hilsen
Danny
Avatar billede supertekst Ekspert
16. april 2008 - 13:48 #1
Hvor vil du have afs. mailadresse og svarene placeret?
Avatar billede mr.9mm Nybegynder
16. april 2008 - 16:24 #2
Jeg havde forstillet mig at, det hele skulle ind i et ark, med mail adresserne i kolonne A, svar 1(=B17) i kolonne B, svar 2(=B18) i kolonne C, osv.
Avatar billede supertekst Ekspert
16. april 2008 - 17:36 #3
Tak for svaret - endnu et spørgsmål:

D.v.s. at det er kun de relevante svarmails, der placeret i en særlig mappe, som du nævner - hvor er denne placeret?
Avatar billede mr.9mm Nybegynder
16. april 2008 - 17:43 #4
Det er inde i Outlook, hvor jeg har lavet en undermappe til indbakken, som hedder spørgeskema.
Avatar billede supertekst Ekspert
16. april 2008 - 17:50 #5
Ok - jeg forsøger at "skrue" noget sammen via VBA...
Avatar billede supertekst Ekspert
16. april 2008 - 23:40 #6
Rem I VBA skal der sættes en reference til Microsoft OutLook. I VBA-vinduet / Tools / References /
Rem Microsoft OutLook 11.0 Object Library (11.0) er 2003-versionen)
Rem ========================================================================
Rem Ellers send en mail til: pb@supertekst-it.dk - så returnerer jeg min fil
Rem ========================================================================

Rem Kør nedenstående makro (hentSvarSkemaer) - med Alt+F8 når denne fil er åbnet.

Rem "Systemet" henter svarfiler fra Outlook og indsætter svar på Ark1 i denne fil

Public Sub henSvarSkemaer()
Dim mailApp, Namespace, indbakke, svMappe, m, vf, aFold
Dim svXLS, sti, afsender, xRæk, xKol

    Set mailApp = CreateObject("Outlook.Application")
    Set Namespace = mailApp.GetNamespace("MAPI")
    Set aFold = Namespace.GetDefaultFolder(olFolderInbox)
    Set svMappe = aFold.Folders("spørgeskema")
       
Rem Hent stien for "systemet"
    sti = ActiveWorkbook.Path
   
Rem Start-række for de indsamlede svar
    xRæk = 1
             
    If svMappe.Items.Count > 0 Then
        For m = 1 To svMappe.Items.Count
           
Rem er der 1 vedhæftet fil
                If svMappe.Items(m).Attachments.Count = 1 Then
                    vf = LCase(svMappe.Items(m).Attachments(1).Filename)
                    afsender = svMappe.Items(m).SenderName
                    xKol = 2
                   
Rem Gem filen midlertidigt filen
                    svMappe.Items(m).Attachments(1).SaveAsFile sti + vf

                    Set svXLS = CreateObject("Excel.Application")
                    With svXLS
                        .Workbooks.Open sti + vf
                        .ActiveWorkbook.Sheets(2).Activate
Rem hent svar fra ark 2
                        Cells(xRæk, 1) = afsender
                        For ræk = 17 To 29
                            svar = .Cells(ræk, 2)
                            Cells(xRæk, xKol) = svar
                            xKol = xKol + 1
                        Next ræk
                        xRæk = xRæk + 1

Rem Slet objekt
                        .Application.Quit
                        Set svXLS = Nothing
                    End With
                   
Rem slet filen igen
                    Kill sti + vf
                End If
        Next m
    End If
   
Rem Tilpas kolonnebredder
    ActiveSheet.Columns.AutoFit
   
Rem Afslutning
    MsgBox ("gennemgang er afsluttet")
End Sub
Avatar billede mr.9mm Nybegynder
18. april 2008 - 23:32 #7
Den vil ikke gøre det, hverken på min vista eller på min xp maskine!
Er der noget jeg kan gøre anderledes, for at gøre det nemmere?
Avatar billede mr.9mm Nybegynder
18. april 2008 - 23:36 #8
jeg kan se at du i toppen har skrevet:

Rem I VBA skal der sættes en reference til Microsoft OutLook. I VBA-vinduet / Tools / References /
Rem Microsoft OutLook 11.0 Object Library (11.0) er 2003-versionen)

kan det have noget med det at gøre, da jeg køre 2007 version?
Avatar billede supertekst Ekspert
18. april 2008 - 23:46 #9
Korrigerer referencen til Microsoft OutLook ?? 12.0 ?? - "vejen" er som nævnt ovenfor...
Avatar billede mr.9mm Nybegynder
19. april 2008 - 00:12 #10
jeg beklager, jeg mente, at det var 2007 jeg kørte med. det var det ikke, og er derfor tilbage på bar bund.
Avatar billede supertekst Ekspert
19. april 2008 - 18:03 #11
Hvad er det så du kører med?
Avatar billede mr.9mm Nybegynder
19. april 2008 - 23:34 #12
Ja grunden til at jeg er forviret, det er jeg køre åbenbart med en 2003 version af excel, men en 2007 version af outlook.
men jeg kan ikke finde referencen til Microsoft OutLook ?? 12.0 i VBA
Avatar billede supertekst Ekspert
20. april 2008 - 00:09 #13
Kan du sende et skærmprint af de referencer, der er aktiveret?
Hvad hedder den reference, der findes til Outlook?
Avatar billede mr.9mm Nybegynder
21. april 2008 - 21:59 #14
Jeg har endelig fået det til at virke, jeg havde lavet en fejl fra starten! Jeg skrev at mappen i outlook lå som en undermappe til indbakken, men det var en undermappe til 'private mapper'. Jeg så fejlen da du sendte mig et skærmprint af dine mapper. Tusinde tak for din tålmodighed, og tak for hjælpen, det hele virker som det skal nu. Lav et svar, så jeg kan give dig dine meget fortjente point.
Avatar billede supertekst Ekspert
22. april 2008 - 14:55 #15
Glædeligt - selv tak - held og lykke med projektet..

Koden var således (før ovenstående bemærkninger fra mr.9mm):

Rem KODEN INDSÆTTES I OUTLOOK (ALT+F11) ThisOutLookSession
Rem Her gemmes de samlede svar:
Const filTilSvar = "c:\svarfil.xls"
Rem ===============================
Public Sub henSvarSkemaer()
Dim mailApp, Namespace, indbakke, svMappe, m, vf, aFold
Dim svXLS, sti, afsender, xRæk, xKol
Dim arkivXLS

On Error GoTo fejl

    Set mailApp = CreateObject("Outlook.Application")
    Set Namespace = mailApp.GetNamespace("MAPI")
    Set aFold = Namespace.GetDefaultFolder(olFolderInbox)
    Set svMappe = aFold.Folders("spørgeskema")
       
    Set arkivXLS = CreateObject("Excel.Application")
    With arkivXLS
        .Workbooks.Open filTilSvar
    End With
   
Rem stien for midlertidig gem af filer
    sti = "c:\"
   
Rem Start-række for de indsamlede svar
    xRæk = 1
             
    If svMappe.Items.Count > 0 Then
        For m = 1 To svMappe.Items.Count
           
Rem er der 1 vedhæftet fil
                If svMappe.Items(m).Attachments.Count = 1 Then
                    vf = LCase(svMappe.Items(m).Attachments(1).FileName)
                    afsender = svMappe.Items(m).SenderName
                    xKol = 2
                   
Rem Gem filen midlertidigt filen
                    svMappe.Items(m).Attachments(1).SaveAsFile sti + vf

                    Set svXLS = CreateObject("Excel.Application")
                    With svXLS
                        .Workbooks.Open sti + vf
                        .ActiveWorkbook.Sheets(2).Activate
Rem hent svar fra ark 2
                        arkivXLS.ActiveWorkbook.Sheets(1).Cells(xRæk, 1) = afsender
                        For ræk = 17 To 29
                            svar = .Cells(ræk, 2)
                            arkivXLS.ActiveWorkbook.Sheets(1).Cells(xRæk, xKol) = svar
                            xKol = xKol + 1
                        Next ræk
                        xRæk = xRæk + 1

Rem Slet objekt
                        .Application.Quit
                        Set svXLS = Nothing
                    End With
                   
Rem slet filen igen
                    Kill sti + vf
                End If
        Next m
    End If
   
Rem Tilpas kolonnebredder
    arkivXLS.ActiveWorkbook.Sheets(1).Columns.AutoFit

Rem Luk arkivfil
    arkivXLS.ActiveWorkbook.Save
    arkivXLS.Application.Quit
    Set arkivXLS = Nothing
Rem Afslutning
    MsgBox ("gennemgang er afsluttet")
   
    Exit Sub
   
fejl:
    MsgBox ("Fejl! - anvend herefter F8 ved Stop - forsæt indtil markeringen kommer op i koden igen - denne viste linie er lige efter fejlen!")

    Stop
    Resume Next
End Sub
Avatar billede Ny bruger Nybegynder

Din løsning...

Tilladte BB-code-tags: [b]fed[/b] [i]kursiv[/i] [u]understreget[/u] Web- og emailadresser omdannes automatisk til links. Der sættes "nofollow" på alle links.

Loading billede Opret Preview
Kategori
Vi har et stort udvalg af Excel kurser. Find lige det kursus der passer dig lige her.

Log ind eller opret profil

Hov!

For at kunne deltage på Computerworld Eksperten skal du være logget ind.

Det er heldigvis nemt at oprette en bruger: Det tager to minutter og du kan vælge at bruge enten e-mail, Facebook eller Google som login.

Du kan også logge ind via nedenstående tjenester