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

Hvor vil du have afs. mailadresse og svarene placeret?

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.

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?

Det er inde i Outlook, hvor jeg har lavet en undermappe til indbakken, som hedder spørgeskema.

Ok - jeg forsøger at "skrue" noget sammen via VBA...

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

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?

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?

Korrigerer referencen til Microsoft OutLook ?? 12.0 ?? - "vejen" er som nævnt ovenfor...

jeg beklager, jeg mente, at det var 2007 jeg kørte med. det var det ikke, og er derfor tilbage på bar bund.

Hvad er det så du kører med?

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

Kan du sende et skærmprint af de referencer, der er aktiveret?
Hvad hedder den reference, der findes til Outlook?

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.

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