Thema Datum  Von Nutzer Rating
Antwort
11.03.2022 12:12:21 Stefan
NotSolved
Blau Fest definierte Zellen aus Excel Dateien in neue Datei schreiben
 12.03.2022 12:00:02 volti
NotSolved

Ansicht des Beitrags:
Von:
volti		 Datum:
12.03.2022 12:00:02		 Views:
407		 Rating:
     
Antwort:
  Ja
Thema:
Fest definierte Zellen aus Excel Dateien in neue Datei schreiben

Hallo Stefan,

<<<<Ist es möglich dies mittels Makro / VBA automatisiert erledigen zu lassen?>>>> ja, das ist möglich

Unten mal ein Ansatz, wie man das machen könnte. Zielblatt ist in der Datei, in der das Makro drin ist....

Da Deine Angaben ungenau sind, erfolgt die Ausgabe nacheinander in ein Array, damit es schneller geht.

Code:
01
02
03
04
05
06
07
08
09
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41		  
Option Explicit

Sub Datenübernahme()
  Dim WKb As Workbook, WSh As Worksheet
  Dim sArrFelder() As String, sPfad As String, sDatei As String
  Dim vArr() As Variant
  Dim i As Long, iZl As Long, iSp As Long

  sPfad = "C:\Users\voltm\Desktop\"          ' Quellpfad
  sDatei = Dir$(sPfad & "*.xlsx")            ' Quelldateimaske
  sArrFelder = Split("B18 B25")              ' Zu übernehmende Felder

  If sDatei = "" Then
     MsgBox "Es wurden keine Import-Dateien gefunden!", vbExclamation, "Datenimport"
     Exit Sub
  End If

  Application.ScreenUpdating = False

  iZl = 0: iSp = UBound(sArrFelder)
  Do While sDatei <> ""
     Set WKb = Workbooks.Open(Filename:=sPfad & sDatei, ReadOnly:=True, UpdateLinks:=False)

     For Each WSh In WKb.Worksheets
         ReDim Preserve vArr(iSp, iZl)
         For i = 0 To iSp
             vArr(i, iZl) = WSh.Range(sArrFelder(i)).Value
         Next i
         iZl = iZl + 1
     Next WSh

     WKb.Close SaveChanges:=False                        ' Mappe schließen
     sDatei = Dir$
  Loop
' Jetzt Daten in Zielblatt ausgeben
  ThisWorkbook.Sheets("Tabelle1").Range("A1").Resize(iZl, iSp + 1).Value = Application.Transpose(vArr) _
                                                          
  Application.ScreenUpdating = True

  MsgBox "Fertig"
End Sub
_________
viele Grüße
Karl-Heinz

Ihre Antwort
  • Bitte beschreiben Sie Ihr Problem möglichst ausführlich. (Wichtige Info z.B.: Office Version, Betriebssystem, Wo genau kommen Sie nicht weiter)
  • Bitte helfen Sie ebenfalls wenn Ihnen geholfen werden konnte und markieren Sie Ihre Anfrage als erledigt (Klick auf Häckchen)
  • Bei Crossposting, entsprechende Links auf andere Forenbeiträge beifügen / nachtragen
  • Codeschnipsel am besten über den Code-Button im Text-Editor einfügen
  • Die Angabe der Emailadresse ist freiwillig und wird nur verwendet, um Sie bei Antworten auf Ihren Beitrag zu benachrichtigen
Thema: Name: Email:



  • Bitte beschreiben Sie Ihr Problem möglichst ausführlich. (Wichtige Info z.B.: Office Version, Betriebssystem, Wo genau kommen Sie nicht weiter)
  • Bitte helfen Sie ebenfalls wenn Ihnen geholfen werden konnte und markieren Sie Ihre Anfrage als erledigt (Klick auf Häckchen)
  • Bei Crossposting, entsprechende Links auf andere Forenbeiträge beifügen / nachtragen
  • Codeschnipsel am besten über den Code-Button im Text-Editor einfügen
  • Die Angabe der Emailadresse ist freiwillig und wird nur verwendet, um Sie bei Antworten auf Ihren Beitrag zu benachrichtigen

Thema Datum  Von Nutzer Rating
Antwort
11.03.2022 12:12:21 Stefan
NotSolved
Blau Fest definierte Zellen aus Excel Dateien in neue Datei schreiben
 12.03.2022 12:00:02 volti
NotSolved