Live-Forum - Die aktuellen Beiträge
Anzeige
Archiv - Navigation
1096to1100
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

Daten auslesen und in neue Datei schreiben

Daten auslesen und in neue Datei schreiben
Dietmar
Hallo zusammen,
Möchte aus einer Excel-Mappe, die aus ca. 10 Tabellenblättern besteht, Daten in eine andere Excel-Mappe übertragen.
Es geht darum, dass ich ein kleines Programm geschrieben habe, in dem Ergebnisdaten etnhalten sind. Es kommt nun vor, dass mir die Datei zurückgeschickt wird, weil er der Anwender einiges "zerschossen" hat. Da ich nicht die Zeit aufwenden möchte, um eine eine Reparatur vorzunehmen, möchte ich lieber die relevaten Daten auslesen und in die unversehrte Datei übertragen.
Situation:
Die defekte Datei heißt beispielsweise: "Quelldatei" und liegt in folgendem Pfad: C:\Testordner
Die neue Datei heißt z.B. "Zieldatei" und liegt im gleichen Ordner.
Die Tabellenstruktur beider Dateien ist gleich. Aus der Tabelle 1 und der Tabelle 2 der defekten Quelldatei sind jeweils Datenbereiche (sagen wir ("A2:A10") und ("B11:C20") auszulesen und in die Zieldatei an die gleichen Stellen zu übertragen.
Am liebsten wäre mir eine Lösung, in der aus der Zieldatei heraus (die dann geöffnet ist) ein Makro gestartet wird, das die Daten aus der "Quelldatei" ausliest. Wenns geht, ohne sie zu öffnen; das wäre aber nicht so wichtig.
Ich vermute, dass das Makkro hin- und herspringen muss um die jeweiligen Bereiche der Tabellenblätter zu kopieren, um Sie anschließend in die Zieldatei einzufügen.
Kann mir jemand helfen oder mit sagen, wo ich ein entsprechendes Beispiel finden kann.
Vielen Dank
Dietmar aus Aachen

2
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Benutzer
Anzeige
AW: Daten auslesen und in neue Datei schreiben
29.08.2009 18:54:18
Josef
Hallo Dietmar,
der Code gehört in die Zieldatei.
' **********************************************************************
' Modul: Modul1 Typ: Allgemeines Modul
' **********************************************************************

Option Explicit

Sub TestGetValue()
  Dim strFile As String, strPath As String, strWBook As String, strSheet As String
  Dim strCell() As String, strRef As String, strRange() As String
  Dim lngIndex As Long, lngCell As Long, rng As Range
  
  strFile = Application.GetOpenFilename("Excel Dateien (*.xls; *.xlsx; *.xlsm)," & _
    "*.xls; *.xlsx; *.xlsm", 1, "Datei zum Datenimport auswählen")
  
  If strFile = "Falsch" Then Exit Sub
  
  
  strPath = Left(strFile, InStrRev(strFile, "\"))
  strWBook = Right(strFile, Len(strFile) - Len(strPath))
  
  
  strRef = "Tabelle1!A5:A100,B3,B5;Tabelle2!F15:F20,H15:H20;Tabelle3!C2"
  'Tabellenname!Zelladresse(n) - Anpassen!
  'Tabellen getrennt durch ; - Zellen(bereiche) getrennt durch ,
  
  strRange = Split(strRef, ";")
  
  For lngIndex = 0 To UBound(strRange)
    strSheet = Left(strRange(lngIndex), InStr(1, strRange(lngIndex), "!") - 1)
    strCell = Split(Mid(strRange(lngIndex), InStr(1, strRange(lngIndex), "!") + 1), ",")
    For lngCell = 0 To UBound(strCell)
      For Each rng In Range(strCell(lngCell))
        ThisWorkbook.Sheets(strSheet).Range(rng.Address) = _
          GetValue(strPath, strWBook, strSheet, rng.Address)
      Next
    Next
  Next
  
End Sub

Private Function GetValue(path As String, file As String, _
    sheet As String, ref As String)

  ' Retrieves a value from a closed workbook
  Dim arg As String
  ' Make sure the file exists
  If Right(path, 1) <> "\" Then path = path & "\"
  
  If Dir(path & file) = "" Then
    GetValue = "File Not Found"
    Exit Function
  End If
  
  ' Create the argument
  arg = "'" & path & "[" & file & "]" & sheet & "'!" & _
    Range(ref).Range("A1").Address(, , xlR1C1)
  
  ' Execute an XLM macro
  GetValue = ExecuteExcel4Macro(arg)
End Function

Gruß Sepp

Anzeige
AW: Daten auslesen und in neue Datei schreiben
29.08.2009 21:13:33
Dietmar
Hallo Sepp,
Super! besten Dank!
und
Viele Grüße
aus Aachen
Gruß Dietmar

46 Forumthreads zu ähnlichen Themen

Anzeige
Anzeige
Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige