Microsoft Excel

Herbers Excel/VBA-Archiv

Informationen und Beispiele zum Thema MsgBox
BildScreenshot zu MsgBox MsgBox-Seite mit Beispielarbeitsmappe aufrufen

Objekt auslesen und in andere Excaldatei kopieren

Betrifft: Objekt auslesen und in andere Excaldatei kopieren von: kathrin
Geschrieben am: 12.08.2014 09:18:41

Guten Morgen,

ich möchte gerne eine Grafik die in mehreren Exceldateien vorhanden ist auslesen und in eine andere bereits bestehende Exceldatei einfügen.

Die Grafik ist in allen Dateien der Grunddaten immer im Tabellenblatt Kalkulation Bereich Y4:AB8 abgelegt. Es besteht eine Datei zur Zusammenfassung, diese übernimmt bereits Werte aus den Grunddateien, um die wichtigsten Angaben eines Projekts auf einen Blick zu sehen.

Da es sich immer um mehrere verschiedene Teile handelt, wäre es super, wenn das Bild mit übernommen werden könnte und in einer bestimmten Zelle eingefügt werden würde.

Vielen Dank im Voraus für eure Hilfe und mal ein großes Lob an dieses Forum.
Ich habe hier super Unterstützung von vielen hilfsbereiten Mitgliedern erhalten.

Freundliche Grüße
Kathrin

  

Betrifft: AW: Objekt auslesen und in andere Excaldatei kopieren von: fcs
Geschrieben am: 12.08.2014 11:30:51

Hallo Katrin,

worum handelt es sich bei der Grafik? Diagramm, Form, Bild?

Was soll ausgelesen/kopiert werden?

Grundsätzlich kann man ein in eine Tabelle eingefügtes Objekt an Hand der Adresse der TopLeftCell ermittel und einer entsprechenden ObjektVariablen zuweisen. Aber was soll anschließend passieren?

Gruß
Franz


  

Betrifft: AW: Objekt auslesen und in andere Excaldatei kopieren von: kathrin
Geschrieben am: 12.08.2014 12:19:14

Hallo Franz,

es ist ein Bild eines Artikels, meist als Screenshot aufgenommen. Das Bild aus der Grunddatei soll kopiert werden und in die Zusammenfassung aufgenommen werden, die einen Überblick aller Artikel im Projekt darstellt.

Die Zusammenfassungsdatei, ließt aus allen Exceldateien, die mit ihr in einem Ordner abgelegt sind, bestimmte Werte zu jedem Artikel des Projekts aus, und kopiert diese Werte in eine Tabellenblatt der Zusammenfassungsdatei.

Super wäre jetzt wenn man das Bild zum passenden "Datensatz" mit einfügen könnte.

Gruß Kathrin


  

Betrifft: AW: Objekt auslesen und in andere Excaldatei kopieren von: fcs
Geschrieben am: 12.08.2014 12:40:14

Hallo Katrin,

hier ein Beispielmakro

Gruß
Franz

Sub aaTest()

  Dim objShape As Shape
  Dim wkbAktiv As Workbook
  Set wkbAktiv = ActiveWorkbook
  
  Set objShape = fncGetShapeObject(wkb:=Workbooks("Mappe3.xlsx"), strWks:="Kalkulation", _
      strTopLeftCell:="Y4")
  If Not objShape Is Nothing Then
    With wkbAktiv.Worksheets("Tabelle2") 'Tabellenblatt in dem eingefügt werden soll
      .Activate
      .Range("B5").Select 'Zelle der linken oberen Ecke des Objekts nach dem Einfügen
      objShape.Copy
      .Paste
    End With
  End If
End Sub

Function fncGetShapeObject(wkb As Workbook, strWks As String, strTopLeftCell As String) As  _
Shape
  'wkb = Arbeitsmappe aus der das Shape kopiert werden soll
  'strWks = Name des Tabellenblatts auf dem sich das zu kopierende Shape befindet.
  'strTopLeftCell = Adresse der Zelle in der sich die linke obere Ecke des Shape-Objekts  _
befindet
  Dim objShape As Shape
  For Each objShape In wkb.Worksheets(strWks).Shapes
    If objShape.TopLeftCell.Address(False, False, xlA1) = strTopLeftCell Then
      Set fncGetShapeObject = objShape
    End If
  Next
End Function



  

Betrifft: AW: Objekt auslesen und in andere Excaldatei kopieren von: kathrin
Geschrieben am: 12.08.2014 13:35:28

Hallo Franz,

habe es versucht. Zeigt immer Meldung: Index außerhalb des gültigen Bereiches.
Sagt dir das was?

Ich habe nur Mappe3.xlsm geändert in den Dateinamen den meine Datei hat mit .xls

Gruß Kathrin


  

Betrifft: AW: Objekt auslesen und in andere Excaldatei kopieren von: fcs
Geschrieben am: 12.08.2014 13:56:24

Hallo Kathrin,

die Datei aus der das Bild kopiert werden soll muss zum Zeitpunkt, wenn das Makro ausgeführt wird, schon geöffnet sein oder das Öffnen der Datei muss noch in das Makro integriert werden.

Ich war davon ausgegangen, dass die Quelldatei schon geöffnet ist, da du ja auch andere Daten aus der Datei in deine Übersicht überträgst. In dieses Makro müsstest du eigentlich das Kopieren der Bilder integrieren können.

Gruß
Franz


  

Betrifft: AW: Objekt auslesen und in andere Excaldatei kopieren von: kathrin
Geschrieben am: 12.08.2014 14:25:01

Hallo Franz,

erstmal vielen Dank für deine bisherige Hilfe.

Ich dachte nicht, dass sich das integrieren für mich als so schwer erweisen würde, als ich die Frage ins Forum stellte, da ich im letzten halben Jahr mich mehr mit Makros befasst habe und dachte mein Kenntnisstand würde ausreichen.

Doch ich habe jetzt leider keine Ahnung wo ich Teile deines Makros einbauen soll. Kannst du mir dabei noch helfen?

Die Zusammenfassungsdatei erkennt selbst wo sie liegt und die Namen der Dateien, die sie durchsuchen soll. Auf einem Tabellenblatt wird eingetragen aus welchem Tabellenblatt der Grunddaten welche Zelle übertragen werden soll. Ich vermute es müsste dort dazugefügt werden, was ich jetzt fett und kursiv hervorgehoben habe.

Option Explicit
Private wbZiel As Workbook
Private wksZiel As Worksheet
Private wksSteuer As Worksheet
Private Zeile As Long, sZelle As String, Spalte As Long

'#### Sub-Routine zum Auslesen von Dateinamen in einem Ordner, Optional inkl. Unter-Ordner
'Quelle: https://www.herber.de/forum/archiv/1064to1068/t1064122.htm#1064890
'Modifiziert: fcs 2010-08-07
Public plCount As Long, parrFiles() As String

Public Sub ListFilesInFolder(ByVal SourceFolderName As String, _
    Optional DateiFormat As String = "*.*", _
    Optional IncludeSubfolders As Boolean = False, _
    Optional FolderName As Boolean = False)
  'SourceFolderName   = Ordner, wo soll gesucht werden?
  'DateiFormat        = Like-Vergleich für Dateinamen, * als Platzhalter verwenden, Optional -  _
leer ist alle
  'IncludeSubfolders  = Unterordner mit durchsuchen - True = Ja , False = Nein, Optional
  'FolderName         = Dateiname inkl. Pfad ausgeben -  True = Ja, False = Nein, Optional
  'Erstellt gemäß Suchkriterien ein Array mit den Dateinamen - optional inkl. Pfad
  Dim FSO As Object, SourceFolder As Object, SubFolder As Object
  Dim FileItem
  Set FSO = CreateObject("Scripting.FileSystemObject")
  Set SourceFolder = FSO.GetFolder(SourceFolderName)
        
  On Error GoTo Err_Zugriff: 'sollte Ordner geschützt sein

'*******************************weitere Eigenschaften ********
  'Name: FileItem.Name
  'Pfad mit Dateiname: FileItem.Path
     
    For Each FileItem In SourceFolder.Files
        If LCase(FileItem.Name) Like LCase(DateiFormat) Then
          plCount = plCount + 1
          ReDim Preserve parrFiles(1 To plCount)
          parrFiles(plCount) = IIf(FolderName, FileItem, FileItem.Name)
        End If
    Next FileItem
    
    If IncludeSubfolders Then
        For Each SubFolder In SourceFolder.SubFolders
            ListFilesInFolder SubFolder.Path, DateiFormat, IncludeSubfolders, FolderName
        Next SubFolder
    End If

Err_Zugriff:
    Set FileItem = Nothing: Set SourceFolder = Nothing: Set FSO = Nothing
End Sub

'### Zusammenfassung: Altdaten löschen, Daten aus den Dateien auslesen und in Zusammenfassung einfügen ###
Sub Zusammenfassung_Erstellen()
Dim strOrdner As String
Dim lFile As Long, StatusCalc As Long
Dim ZeileLetzte As Long
Dim lngZeile1 As Long

On Error GoTo Fehler

Set wksSteuer = ThisWorkbook.Worksheets("Steuerung")
'Zieldatei/-Tabellenblatt setzen
Set wbZiel = ThisWorkbook
Set wksZiel = wbZiel.Worksheets("Zusammenfassung") 'Name des Zielblatts ggf. anpassen
'1. Zeile in die Daten in der Zusammenfassung eingetragen werden
lngZeile1 = wksZiel.Range("Zeile_Daten_1").Row

'zu durchsuchendes Verzeichnis gleich dem Ordner dieser Datei setzen
strOrdner = wbZiel.Path
wksSteuer.Range("Verzeichnis") = strOrdner

StatusCalc = Application.Calculation 'Berechnungsmethode merken

'Altdaten unterhalb der Spaltentitel in Zieltabelle löschen
With wksZiel
'Letzte Datenzeile in Zusammenfassung in Spalte A
With .UsedRange
ZeileLetzte = .Row + .Rows.Count - 1
End With
If ZeileLetzte >= lngZeile1 Then
'Hyperlinks und Inhalte löschen
.Range(.Rows(lngZeile1), .Rows(ZeileLetzte)).ClearContents
End If
ZeileLetzte = lngZeile1 - 1
End With

'Dateiliste zurücksetzen
plCount = 0
Erase parrFiles

'Dateiliste erstellen
Call ListFilesInFolder(SourceFolderName:=strOrdner, _
DateiFormat:="*.xls*", _
IncludeSubfolders:=wksSteuer.Range("Unterverzeichnisse") = "Ja", _
FolderName:=True)

If plCount <= 1 Then
MsgBox "Keine Kalkulationsdateien im Verzeichnis """ & strOrdner & """ gefunden", _
vbInformation, "Z U S A M M E N F A S S U N G erstellen"
Else
'Makrobremsen lösen
With Application
.ScreenUpdating = False
.EnableEvents = False
.Calculation = xlCalculationManual
End With

'gefundene Dateien abarbeiten
For lFile = 1 To plCount
If fncCheckOeffnen(parrFiles(lFile)) = True Then
Application.StatusBar = "Bearbeite Datei " & lFile & " von " & plCount & "," _
& parrFiles(lFile)
ZeileLetzte = ZeileLetzte + 1
Call Daten_Auslesen(sFilename:=parrFiles(lFile), ZeileZiel:=ZeileLetzte)
End If
Next

'Summenzeile gemäß Vorgaben im Blatt Steuerung im Zielblatt einfügen
ZeileLetzte = ZeileLetzte + 2 'eine Leerzeile lassen
With wksSteuer
For Zeile = .Range("StartListe").Row + 1 To .Cells(.Rows.Count, 2).End(xlUp).Row
Spalte = .Cells(Zeile, 4).Value
sZelle = .Cells(Zeile, 5).Text
With wksZiel.Cells(ZeileLetzte, Spalte)
Select Case sZelle
Case ""
Case "Formel"
.FormulaR1C1 = "=SUM(R" & lngZeile1 & "C:R[-2]C)"
Case Else
.Value = sZelle
End Select
End With
Next
End With
'Druckbereich anpassen
With wksZiel
With wksZiel.Names("Print_Area").RefersToRange
Spalte = .Column + .Columns.Count - 1
sZelle = .Range("A1").Address & ":" & wksZiel.Cells(ZeileLetzte, Spalte).Address
End With
.PageSetup.PrintArea = sZelle
End With

With Application
.ScreenUpdating = True
.StatusBar = False
End With

MsgBox "Fertig", vbInformation, "Z U S A M M E N F A S S U N G erstellen"


wksZiel.Range("Zeit_Aktualisierung") = Now
wksZiel.Activate
End If
Err.Clear
'Fehlerbehandlung
Fehler:
With Err
Select Case .Number
Case 0 'Alles OK
Case Else
MsgBox "Fehler-Nr: " & .Number & vbLf & .Description
End Select
End With

'Makrobremsen zurücksetzen
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = StatusCalc
.StatusBar = False
End With

'Variablen aufräumen
'Dateiliste wieder entleeren
plCount = 0
Erase parrFiles
Set wbZiel = Nothing: Set wksZiel = Nothing: Set wksSteuer = Nothing
End Sub
Private Sub Daten_Auslesen(ByVal sFilename As String, ByVal ZeileZiel As Long)
  Dim wbQuelle As Workbook
  Dim sNameBlatt As String
  'Datei mit Artikel-Kalkulation schreibgeschützt öffnen, ggf. inkl. Aktualisierung externer  _
Verknüpfungen
  Set wbQuelle = Application.Workbooks.Open(Filename:=sFilename, _
                UpdateLinks:=wksSteuer.Range("Verknuepfungen") = "Ja", _
                ReadOnly:=True)
  If wksSteuer.Range("Berechnen") = "Ja" Then Application.Calculate
  'Name der Quelldatei in Zielblatt eintragen und Hyperlink einfügen
  With wksZiel
    'Hyperlink zu Datei einfügen
    .Hyperlinks.Add Anchor:=.Cells(ZeileZiel, 1), Address:=wbQuelle.FullName, _
        ScreenTip:=wbQuelle.Name
    .Cells(ZeileZiel, 1) = wbQuelle.Name
  End With
  
  'Zellen mit den Kalkulationsdaten gemäß Vorgaben im Blatt Steuerung auslesen und in  _
Zielblatt eintragen
  With wksSteuer
    For Zeile = .Range("StartListe").Row + 1 To .Cells(.Rows.Count, 2).End(xlUp).Row
      sNameBlatt = .Cells(Zeile, 2).Text
      sZelle = .Cells(Zeile, 3).Value
      Spalte = .Cells(Zeile, 4).Value
      If fncCheckSheet(varBlatt:=sNameBlatt, wb:=wbQuelle) = True Then
        wksZiel.Cells(ZeileZiel, Spalte) = wbQuelle.Worksheets(sNameBlatt).Range(sZelle)
      Else
        MsgBox "Tabelle """ & sNameBlatt & """ ist in Datei """ & wbQuelle.Name & """ nicht  _
vorhanden!", _
            vbInformation + vbOKOnly, "Prozedur: Daten_Auslesen"
      End If
    Next
  End With
  wbQuelle.Close savechanges:=False
  Set wbQuelle = Nothing
End Sub

Private Function fncCheckOeffnen(ByVal strFile As String) As Boolean
  'Prüfen, ob Datei strFile geöffnet werden darf
  'Hier werden Ausnahmen festgelegt für Excel-Dateien, die bei der Erstellung der  _
Zusammenfassung nicht _
        berücksichtig werden dürfen
  Dim strDatei As String
  
  fncCheckOeffnen = True
  'Dateiname von Pfad\Dateiname abtrennen
  strDatei = LCase(Mid(strFile, InStrRev(strFile, "\") + 1))
  Select Case strDatei
    Case LCase(ThisWorkbook.Name), "zusammenfassung.xls", "zusammenfassung.xlsm"
        'Diese Dateien nicht in Zusammenfassung darstellen
        fncCheckOeffnen = False
  End Select
End Function

Public Function fncCheckSheet(ByVal varBlatt, Optional wb As Workbook) As Boolean
  'Prüft ob Blatt in Arbeitsmappe vorhanden
  Dim objSheet As Object
  On Error GoTo Fehler
  If wb Is Nothing Then Set wb = ActiveWorkbook
  fncCheckSheet = True
  Set objSheet = wb.Sheets(varBlatt)
Fehler:
  With Err
    Select Case .Number
      Case 0 'Alles ok
      Case Else
       fncCheckSheet = False
    End Select
  End With
End Function



  

Betrifft: AW: Objekt auslesen und in andere Excaldatei kopieren von: kathrin
Geschrieben am: 12.08.2014 14:42:42

Hallo Franz,

habe gerade mal nachgeschaut. Du warst ja schon vor nem halben Jahr mein Helfer in der Not, der mir dieses tolle Makro zur Verfügung gestellt hat.

Danke nochmals.


 

Beiträge aus den Excel-Beispielen zum Thema "Objekt auslesen und in andere Excaldatei kopieren"