Dateien zusammenführen - In Spalten kopieren

Guten Morgen Excelforum,
als VBA-Laie bin ich wieder einmal auf Eure Hilfe angewiesen:
Ich bekomme aus einer Umfrage Excel-Dateien zurück, die ich in einer Gesamtdatei auswerten muss. Die Antworten speichere ich in einem Ordner C:\Fortbildung, die einzelnen Dateien nenne ich Fortbildung_1.xls, Fortbildung_2.xls, usw. Wieviele Dateien es werden, weiß ich noch nicht, es können aber durchaus 100 Dateien sein. Die Antworten stehen immer im Zellbereich C11:D47.
Nun möchte ich in die Datei C\Fortbildung\Auswertung.xls, beginnend in C11:D47 die Antoworten aus der ersten Datei Fortbildung_1.xls kopieren, daneben in Spalte E11:F47 die Antworten aus der zweiten Datei, in G11:H47 die Antworten aus der dritten DAtei, usw. Die Spalten der Anwortdateien, die immer in C11:D47 stehen, sollen also in der Auswertung nebeneinander kopiert werden. In der Recherche habe ich immer nur die Möglichkeit gefunden, in Zeilen untereinander zu kopieren.
Es wäre wunderbar, wenn mir jemand helfen könnte!
Karin

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub Kopieren() Dim lstrFile As String, lstrPath As String, liCol As Integer lstrPath = "C:\Fortbildung\" lstrFile = Dir(lstrPath & "Fortbildung_*.xls") liCol = 67 Application.ScreenUpdating = False Do Until lstrFile = "" If lstrFile ThisWorkbook.Name Then Workbooks.Open lstrPath & lstrFile ActiveWorkbook.Sheets(1).Range("C11:D47").Copy ThisWorkbook.Sheets(1).Activate ThisWorkbook.Sheets(1).Range(Chr(liCol) & 11).Select ActiveSheet.Paste Application.CutCopyMode = False liCol = liCol + 2 Workbooks(lstrFile).Close False lstrFile = Dir End If Loop Application.ScreenUpdating = True End Sub

Hallo,
gut gemacht, aber besser ohne "Select" und "Activate".
' **********************************************************************
' Modul: Modul1 Typ: Allgemeines Modul
' **********************************************************************

Option Explicit

Sub Kopieren()
Dim lstrFile As String, lstrPath As String, intC As Integer
Dim objThWBSh As Worksheet, objWB As Workbook

Set objThWBSh = ThisWorkbook.Sheets(1)

lstrPath = "C:\Fortbildung\"
lstrFile = Dir(lstrPath & "Fortbildung_*.xls")
intC = 3

On Error GoTo ErrExit

GMS

Do Until lstrFile = ""
    If lstrFile <> ThisWorkbook.Name Then
        Set objWB = Workbooks.Open(lstrPath & lstrFile)
        objWB.Sheets(1).Range("C11:D47").Copy objThWBSh.Cells(11, intC)
        intC = intC + 2
        objWB.Close False
        lstrFile = Dir
    End If
Loop

ErrExit:

GMS True

Set objThWBSh = Nothing
Set objWB = Nothing

End Sub

Sub GMS(Optional ByVal Modus As Boolean = False)

With Application
    .ScreenUpdating = Modus
    .EnableEvents = Modus
    .DisplayAlerts = Modus
    .EnableCancelKey = IIf(Modus, 1, 0)
    .Calculation = IIf(Modus, -4105, -4135)
    .Cursor = IIf(Modus, -4143, 2)
End With

End Sub

Gruß Sepp

Beliebteste Forumthreads (12 Monate)

Dateien zusammenführen - In Spalten kopieren

8 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

8
Beiträge zum Forumthread

Beiträge zu diesem Forumthread