Live-Forum - Die aktuellen Beiträge
Anzeige
Archiv - Navigation
1128to1132
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

@Sepp: Zwei Bitten! | Herbers Excel-Forum

@Sepp: Zwei Bitten!
09.01.2010 20:02:38
Claudia

Hallo Sepp,
Du hattest mir netterweise folgenden VBA-Code geschrieben.
https://www.herber.de/forum/archiv/1116to1120/t1118104.htm#1118104
Hierzu habe ich zwei Bitten.
Ich hole mir auch Tabellen aus Dateien, die Verknüpfungen haben. Beim rüberkopieren werde ich so also immer gefragt und muss das aktualisieren manuell bejahen. Kannst Du diese Abfrage noch in den Code einbauen?
Zweite Bitte: Manche Dateien beinhalten die gleichen Tabellennamen, so dass beim rauskopieren diese Sheets dann in meiner Datei hochgezählt werden.
Werte
Werte(2)
Werte(3)
Es wäre prima, wenn hier folgende Lösung möglich ist. In meinem Reiter Übersicht trage ich ja in Spalte B ein, welche Tabelle rauskopiert werden soll. Wäre es möglich, wenn ich in der gleichen Zelle dahinter mit einem Bindestrich ggf. den neuen Namen eintragen kann, wie die rausgekopierte Tabelle in meiner Datei dann heissen soll.
Beispiel: Werte - danke
gesuchte Tabelle = Werte
soll dann in meiner Datei heissen =danke
Verständändlich? Wärst Du so nett?
Vielen lieben Dank im Voraus!
LG
Claudia

4
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
Sepp: Hier nun der Code:
09.01.2010 20:10:13
Claudia
Der betreffende Code - sehe ich gerade - ist aber folgender. Hatte ich im Forum aufgelesen. Den Code müsstest Du auch geschrieben haben. Glaube ich zumindest.
' **********************************************************************
' Modul: Modul1 Typ: Allgemeines Modul
' **********************************************************************
Option Explicit
Sub importSheets()
Dim objSh As Worksheet, objDel As Worksheet, objWb As Workbook
Dim lngRow As Long, lngLast As Long
On Error GoTo ErrExit
GMS
Set objSh = Sheets("Übersicht")
With objSh
For Each objDel In .Parent.Worksheets
If Not objDel Is objSh Then objDel.Delete
Next
lngLast = Application.Max(2, .Cells(.Rows.Count, 1).End(xlUp).Row)
.Range("C2:C" & Rows.Count).ClearContents
For lngRow = 2 To lngLast
If .Cells(lngRow, 1) <> "" Then
If Dir(.Cells(lngRow, 1).Text, vbNormal) <> "" Then
Set objWb = Workbooks.Open(.Cells(lngRow, 1).Text)
If SheetExist(.Cells(lngRow, 2).Text, objWb) Then
objWb.Sheets(.Cells(lngRow, 2).Text).Copy After:=.Parent.Sheets(.Parent.Sheets.Count)
.Cells(lngRow, 3) = "Importiert"
Else
.Cells(lngRow, 3) = "Tabelle nicht vorhanden"
End If
objWb.Close False
Else
.Cells(lngRow, 3) = "Datei nicht vorhanden"
End If
End If
Next
.Activate
End With
ErrExit:
With Err
If .Number <> 0 Then MsgBox "Fehler " & .Number & vbLf & vbLf & _
.Description & vbLf & vbLf & "In Prozedur (importSheets) in Modul Modul1", _
vbExclamation, "Fehler in Modul1 / importSheets"
End With
GMS True
Set objWb = Nothing
Set objSh = Nothing
Set objDel = Nothing
End Sub
Public Sub GMS(Optional ByVal Modus As Boolean = False)
Static lngCalc As Long
With Application
.ScreenUpdating = Modus
.EnableEvents = Modus
.DisplayAlerts = Modus
.EnableCancelKey = IIf(Modus, 1, 0)
If Not Modus Then lngCalc = .Calculation
If Modus And lngCalc = 0 Then lngCalc = -4105
.Calculation = IIf(Modus, lngCalc, -4135)
.Cursor = IIf(Modus, -4143, 2)
End With
End Sub

Private Function SheetExist(ByVal sheetName As String, Optional Wb As Workbook) As Boolean
Dim wks As Worksheet
On Error GoTo ERRORHANDLER
If Wb Is Nothing Then Set Wb = ThisWorkbook
For Each wks In Wb.Worksheets
If wks.Name = sheetName Then SheetExist = True: Exit Function
Next
ERRORHANDLER:
SheetExist = False
End Function

Anzeige
AW: Sepp: Hier nun der Code:
09.01.2010 20:24:33
Josef Ehrensberger
Hallo Claudia,
ungetestet.
' **********************************************************************
' Modul: Modul1 Typ: Allgemeines Modul
' **********************************************************************

Option Explicit

Sub importSheets()
  Dim objSh As Worksheet, objDel As Worksheet, objWb As Workbook
  Dim lngRow As Long, lngLast As Long, vntName As Variant
  
  
  On Error GoTo ErrExit
  GMS
  Set objSh = Sheets("Übersicht")
  
  With objSh
    For Each objDel In .Parent.Worksheets
      If Not objDel Is objSh Then objDel.Delete
    Next
    
    lngLast = Application.Max(2, .Cells(.Rows.Count, 1).End(xlUp).Row)
    
    .Range("C2:C" & Rows.Count).ClearContents
    
    For lngRow = 2 To lngLast
      If .Cells(lngRow, 1) <> "" Then
        If Dir(.Cells(lngRow, 1).Text, vbNormal) <> "" Then
          If InStr(1, .Cells(lngRow, 2).Text, "-") > 0 Then
            vntName = Split(.Cells(lngRow, 2), "-")
          Else
            vntName = Array(.Cells(lngRow, 2).Text, .Cells(lngRow, 2).Text)
          End If
          Set objWb = Workbooks.Open(.Cells(lngRow, 1).Text, UpdateLinks:=True)
          If SheetExist(Trim(vntName(0)), objWb) Then
            objWb.Sheets(Trim(vntName(0))).Copy After:=.Parent.Sheets(.Parent.Sheets.Count)
            ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count).Name = Trim(vntName(1))
            .Cells(lngRow, 3) = "Importiert"
          Else
            .Cells(lngRow, 3) = "Tabelle nicht vorhanden"
          End If
          objWb.Close False
        Else
          .Cells(lngRow, 3) = "Datei nicht vorhanden"
        End If
      End If
      Erase vntName
    Next
    .Activate
  End With
  
  
  
  ErrExit:
  With Err
    If .Number <> 0 Then MsgBox "Fehler " & .Number & vbLf & vbLf & _
      .Description & vbLf & vbLf & "In Prozedur (importSheets) in Modul Modul1", _
      vbExclamation, "Fehler in Modul1 / importSheets"
  End With
  
  GMS True
  
  Set objWb = Nothing
  Set objSh = Nothing
  Set objDel = Nothing
End Sub

Public Sub GMS(Optional ByVal Modus As Boolean = False)
  
  Static lngCalc As Long
  
  With Application
    .ScreenUpdating = Modus
    .EnableEvents = Modus
    .DisplayAlerts = Modus
    .EnableCancelKey = IIf(Modus, 1, 0)
    If Not Modus Then lngCalc = .Calculation
    If Modus And lngCalc = 0 Then lngCalc = -4105
    .Calculation = IIf(Modus, lngCalc, -4135)
    .Cursor = IIf(Modus, -4143, 2)
    
  End With
  
End Sub


Private Function SheetExist(ByVal sheetName As String, Optional Wb As Workbook) As Boolean
  Dim wks As Worksheet
  On Error GoTo ERRORHANDLER
  If Wb Is Nothing Then Set Wb = ThisWorkbook
  For Each wks In Wb.Worksheets
    If wks.Name = sheetName Then SheetExist = True: Exit Function
  Next
  ERRORHANDLER:
  SheetExist = False
End Function

Gruß Sepp
Anzeige
AW: @Sepp: Zwei Bitten!
09.01.2010 20:16:39
Josef Ehrensberger
Hallo Claudia,
ich helfe dir gerne, aber in dem von dir angeführten Thread, werden keine Tabellen aus
anderen Dateien importiert. Poste den Code, oder noch besser, lade eine Datei mit dem Code
und den neuen Tabellennamen hoch.
Gruß Sepp
Vielen vielen Dank und noch ein schönes WE
09.01.2010 22:11:20
Claudia

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige