Excel VBA: zweite Excel-Datei öffnen, Werte kopieren und schließen

[Excelmania]

Guten Morgen.

ich habe in Excel einen Fragebogen erstellt.

Die Rückläufer sollen nun ausgewertet werden. Hierzu sind die Antworten in einer Datei zu konsolidieren.

Für die Auswertung habe ich eine zweite Excel-Arbeitsmappe erstellt.

Nun ist meine Idee, dass ich über die VBA die Datei öffnen lasse, die Werte kopiert und unten angefügt werden und dann der Fragebogen wieder geschlossen wird.

Das Auswählen und öffnen der Excel-Arbeitsmappe klappt (nicht jedoch wenn ich auf Abbrechnen) klicke. Das Kopieren funktioniert jedoch nicht.

Private Sub CMD_Daten_anfügen_Click()

    Dim qdatei As Variant
    qdatei = Application.GetOpenFilename _
         ("Excel Arbeitsmappe(*.xlsx),*.xlsx,")
       
    Workbooks.Open qdatei
       
    'letzte Zeile auf Daten
    lz = ThisWorkbook.Worksheets("Daten").UsedRange.SpecialCells(xlCellTypeLastCell).Row
   
    qdatei.Worksheets("Fragebogen").Range("B3").Copy
    ThisWorkbook.Worksheets("Daten").Range("A" & (lz + 1)).PasteSpecial Paste:=xlValues
    pname.Worksheets("Fragebogen").Range("B5:B6").Copy
    ThisWorkbook.Worksheets("Daten").Range("B" & (lz + 1)).PasteSpecial Paste:=xlValues, Transpose:=True
   
    qdatei.Close False
    Application.CutCopyMode = False

End Sub

Der Dateiname zum Fragebogen kann varieren. Das Tabellenblatt "Fragenbogen" ist jedoch statisch.

Noch schöner wäre natürlich, ich könnte ein Verzeichnis auswählen und dann durchläuft Excel eine Schleife für alle Excel-Dateien in diesem Verzeichnis (sind dann natürlich nur die Rückläufer abgelegt).

Ergänzung: Habe hierzu etwas gefunden. Doch leider konnte ich das auf meine Bedürfnisse nicht anpassen:

Private Sub CommandButton1_Click()

Dim strDatnam As String
Dim wb As Workbook
Dim strPfad As String
Dim rngEinfüg As Range

strPfad = "D:\Fragebogen"
strDatnam = Dir(strPfad & "*.xlsx")

Do While strDatnam <> ""
   Set wb = Workbooks.Open(strPfad & strDatnam)
   With ThisWorkbook.Sheets("Daten")
      Set rngEinfüg = IIf(IsEmpty(.Cells(3, 1)), .Cells(3, 1), .Cells(Rows.Count, 1).End(xlUp).Offset(1))
      rngEinfüg = wb.Sheets("Daten").[B3]
      rngEinfüg.Offset(, 2).Resize(, 3) = WorksheetFunction.Transpose(wb.Sheets("Fragebogen").[B5:B6])
   End With
   wb.Close savechanges:=False
   strDatnam = Dir
Loop

Set rngEinfüg = Nothing
Set wb = Nothing

End Sub

Meine Thread füge ich zwei Beispieldateien bei.

 

[tollertyp]

Du solltest auch zwingend das Ergebnis von Application.GetOpenFilename überprüfen, Microsoft hat eigentlich eine gar nicht mal so schlechte Dokumentation...

fileToOpen = Application _
.GetOpenFilename("Text Files (*.txt), *.txt")
If fileToOpen <> False Then
MsgBox "Open " & fileToOpen
End If

Und dein Excel-VBA-Code in den Beispielen compiliert nicht mal... Was ist pname?

 

[Excelmania]

Hallo.

Ich habe es hinbekommen. Jedoch erhalte ich wenn ich Deinen Code anpasse immer noch eine Fehlermeldung. Ich habe es jetzt so gelöst, wenn ich auf Abbrechen klicke:

Private Sub CMD_Daten_anfügen_Click()

    Dim wb As Workbook
    Dim Fname As String

    On Error GoTo 2

    Fname = Application.GetOpenFilename("Excel Arbeitsmappe(*.xlsx),*.xlsx,")
    
    'letzte Zeile auf Daten
    lZ = ThisWorkbook.Worksheets("Daten").UsedRange.SpecialCells(xlCellTypeLastCell).Row
 
    Set wb = Workbooks.Open(Fname, False, True)
    wb.Worksheets("Fragebogen").Range("B3").Copy
    ThisWorkbook.Worksheets("Daten").Range("A" & (lZ + 1)).PasteSpecial Paste:=xlValues
    Set wb = Workbooks.Open(Fname, False, True)
    wb.Worksheets("Fragebogen").Range("B5:B6").Copy
    ThisWorkbook.Worksheets("Daten").Range("B" & (lZ + 1)).PasteSpecial Paste:=xlValues, Transpose:=True
    wb.Close
    
2:
    
End Sub