Live-Forum - Die aktuellen Beiträge
Datum
Titel
18.04.2024 21:09:11
4 Spalten aus smarter Tabelle in andere smarte Tab. kopieren
18.04.2024 20:45:35
Worksheet_Activate für alle Sheets
18.04.2024 19:30:20
VBA - Tabelle mit Mannschaftsergebnissen sortieren
18.04.2024 18:04:29
Formel fehler Wert#
Du findest keine passende Antwort auf Deine Frage?
Stelle Deine Frage in unserem Live-Forum
Anzeige
Archiv - Navigation
984to988
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
Vorheriger Thread
Vorheriger Thread
Rückwärts Blättern
984to988
984to988
Aktuelles Verzeichnis
Verzeichnis Index
Verzeichnis Index
Übersicht Verzeichnisse
Nächster Thread
Nächster Thread
Vorwärts blättern
Inhaltsverzeichnis

Tab kopieren und fortl. nummeriert in neue Datei

Tab kopieren und fortl. nummeriert in neue Datei
19.06.2008 16:12:00
Fritz_W
Hallo Forumsbesucher,
ich würde gerne per VBA-Lösung folgendes umsetzen:
wird in der Tabelle1 der Zellwert in Zelle A171 geändert (neue Eingabe), sollte die Tabelle1 kopiert und - sofern die Arbeitsmappe "Neu" geöffnet ist - die kopierte Tabelle (ohne Formeln, nur als Werte) in diese Arbeitsmappe ("Neu") als Tabelle "A1" einfügen. Gleichzeitig sollte die Tabelle2 der gleichen Arbeitsmappe kopiert werden und ebenfalls (ohne Formeln, nur die Werte) als Tabelle B1 in die geöffnete Arbeitsmappe "Neu" eingefügt werden. Bei der nächsten Veränderung sollten die Tabellen wie vorher ebenfalls kopiert und unter der Bezeichnung A2 bzw. B2 eingefügt werden. Bei der nächsten Veränderung Einfügung unter A3 und B3 usw.
Wäre nett, wenn sich das so in etwa realisieren ließe.
Vielen Dank für eure Unterstützung.
Gruß
Fritz

6
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Tab kopieren und fortl. nummeriert in neue Datei
19.06.2008 20:03:00
Josef
Hallo Fritz,
kopiere den Code in das Modul der Tabelle "Tabelle 1". (Rechtsklick auf das Blattregister > Code Anzeigen)
Der Code ist ungetestet!
' **********************************************************************
' Modul: Tabelle1 Typ: Element der Mappe(Sheet, Workbook, ...)
' **********************************************************************

Option Explicit
Const cWorkBook As String = "C:\Pfad Zur Date\Neu.xls" 'Pfad und Name der Datei "Neu" - Anpassen!


Private Sub Worksheet_Change(ByVal Target As Range)
Dim objWB As Workbook, intIndex As Integer, blnWasOpen As Boolean

1 If Target.Address(0, 0) <> "A171" Then Exit Sub

2 On Error GoTo ErrExit
3 GMS

4 For Each objWB In Application.Workbooks
5 If objWB.FullName = cWorkBook Then
6 blnWasOpen = True
7 Exit For
8 End If
9 Next

10 If objWB Is Nothing Then
11 Set objWB = Workbooks.Open(cWorkBook)
12 End If

13 Do
14 intIndex = intIndex + 1
15 Loop While SheetExist("A" & intIndex, objWB.Name) = True

16 With ThisWorkbook
17 .Sheets("Tabelle 1").Copy after:=objWB.Sheets(objWB.Sheets.Count)
18 objWB.Sheets(objWB.Sheets.Count).Name = "A" & CStr(intIndex)
19 objWB.Sheets("A" & CStr(intIndex)).UsedRange = objWB.Sheets("A" & CStr(intIndex)).UsedRange.Value
20 .Sheets("Tabelle 2").Copy after:=objWB.Sheets(objWB.Sheets.Count)
21 objWB.Sheets(objWB.Sheets.Count).Name = "B" & CStr(intIndex)
22 objWB.Sheets("B" & CStr(intIndex)).UsedRange = objWB.Sheets("B" & CStr(intIndex)).UsedRange.Value
23 End With

24 If blnWasOpen Then objWB.Close True

ErrExit:
25 GMS True
26 If Err.Number > 0 Then
27 MsgBox "Es ist ein Fehler in Zeile " & CStr(Erl) & " aufgetreten!" & vbLf & vbLf & _
    "Fehlernummer:" & vbTab & Err.Number & vbLf & _
    "Fehlerquelle:" & vbTab & Err.Source & vbLf & _
    "Beschreibung:" & vbTab & Err.Description & Space(25), _
    vbExclamation, "Fehler"
28 End If
29 Err.Clear
End Sub

Private 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 Modus Then
        .Calculation = IIf(lngCalc <> 0, lngCalc, xlCalculationAutomatic)
    Else
        lngCalc = .Calculation
        .Calculation = xlCalculationManual
    End If
    .Cursor = IIf(Modus, -4143, 2)
    .CutCopyMode = False
End With

End Sub

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


Gruß Sepp



Anzeige
AW: Tab kopieren und fortl. nummeriert in neue Datei
20.06.2008 12:50:00
Fritz_W
Hallo Sepp,
ich bitte zunächst um Entschuldigung, weil ich mich so spät melde, aber ich konnte den Code
eben erst testen.
Das Ganze funktioniert - entsprechend meinen Vorgaben - einwandfrei.
Damit hast Du mir (wieder einmal) einen große Hilfe geleistet.
Vielen Dank!!!
Gruß
Fritz

@ Sepp - Ergänzung?
20.06.2008 16:11:03
Fritz_W
Hallo Sepp,
ist es sehr arbeitsaufwändig, den Code so zu verändern, dass in der kopierten Tabelle1 der im Tabellenblatt enthaltene Code in den jeweiligen Kopien (Tabellen "A1", "A2" usw) nicht mehr enthalten ist?
Bitte nur Änderungen vornehmen, wenn das für Dich nicht mit allzu viel Arbeit verbunden ist!
Ich bin mit der bisherigen Lösung ansonsten sehr zufrieden!!
Nochmaligen Dank
Gruß
Fritz

Anzeige
AW: @ Sepp - Ergänzung?
20.06.2008 20:45:00
Josef
Hallo
Fritz,
das ist kein Problem.
' **********************************************************************
' Modul: Tabelle1 Typ: Element der Mappe(Sheet, Workbook, ...)
' **********************************************************************

Option Explicit

Const cWorkBook As String = "F:\Temp\Neu.xls" 'Pfad und Name der Datei "Neu" - Anpassen!


Private Sub Worksheet_Change(ByVal Target As Range)
Dim objWB As Workbook, intIndex As Integer, blnWasOpen As Boolean
Dim strCompA As String, strCompB As String

If Target.Address(0, 0) <> "A171" Then Exit Sub

On Error GoTo ErrExit
GMS

For Each objWB In Application.Workbooks
    If objWB.FullName = cWorkBook Then
        blnWasOpen = True
        Exit For
    End If
Next

If objWB Is Nothing Then
    Set objWB = Workbooks.Open(cWorkBook)
End If

Do
    intIndex = intIndex + 1
Loop While SheetExist("A" & intIndex, objWB.Name) = True

With objWB
    ThisWorkbook.Sheets("Tabelle 1").Copy after:=.Sheets(.Sheets.Count)
    .Sheets(.Sheets.Count).Name = "A" & CStr(intIndex)
    .Sheets("A" & CStr(intIndex)).UsedRange = .Sheets("A" & CStr(intIndex)).UsedRange.Value
    ThisWorkbook.Sheets("Tabelle 2").Copy after:=.Sheets(.Sheets.Count)
    .Sheets(.Sheets.Count).Name = "B" & CStr(intIndex)
    .Sheets("B" & CStr(intIndex)).UsedRange = .Sheets("B" & CStr(intIndex)).UsedRange.Value
    strCompA = .Sheets("A" & CStr(intIndex)).CodeName
    strCompB = .Sheets("B" & CStr(intIndex)).CodeName
    With .VBProject
        With .VBComponents(strCompA).CodeModule
            .DeleteLines 1, .CountOfLines
        End With
        With .VBComponents(strCompB).CodeModule
            .DeleteLines 1, .CountOfLines
        End With
    End With
End With

If Not blnWasOpen Then objWB.Close True
ThisWorkbook.Activate

ErrExit:
GMS True
If Err.Number > 0 Then
    MsgBox "Es ist ein Fehler in Zeile " & CStr(Erl) & " aufgetreten!" & vbLf & vbLf & _
        "Fehlernummer:" & vbTab & Err.Number & vbLf & _
        "Fehlerquelle:" & vbTab & Err.Source & vbLf & _
        "Beschreibung:" & vbTab & Err.Description & Space(25), _
        vbExclamation, "Fehler"
End If
Err.Clear
End Sub

Private 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 Modus Then
        .Calculation = IIf(lngCalc <> 0, lngCalc, xlCalculationAutomatic)
    Else
        lngCalc = .Calculation
        .Calculation = xlCalculationManual
    End If
    .Cursor = IIf(Modus, -4143, 2)
    .CutCopyMode = False
End With

End Sub

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


Gruß Sepp



Anzeige
etwas kürzer
20.06.2008 22:19:28
Josef
Hallo nochmal.
' **********************************************************************
' Modul: Tabelle1 Typ: Element der Mappe(Sheet, Workbook, ...)
' **********************************************************************

Option Explicit

Const cWorkBook As String = "F:\Temp\Neu.xls" 'Pfad und Name der Datei "Neu" - Anpassen!

Private Sub Worksheet_Change(ByVal Target As Range)
Dim objWB As Workbook, intIndex As Integer, intCount As Integer, blnWasOpen As Boolean
Dim varSheetName() As Variant, varSheetToCopy() As Variant

1 If Target.Address(0, 0) <> "A171" Then Exit Sub

2 On Error GoTo ErrExit
3 GMS

4 varSheetName = Array("A", "B") 'Namen der Tabellen in "Neu.xls"
5 varSheetToCopy = Array("Tabelle 1", "Tabelle 2") 'Namen der zu kopierenden Tabellen

6 For Each objWB In Application.Workbooks
7 If objWB.FullName = cWorkBook Then
8 blnWasOpen = True
9 Exit For
10 End If
11 Next

12 If objWB Is Nothing Then
13 Set objWB = Workbooks.Open(cWorkBook)
14 End If

15 Do
16 intIndex = intIndex + 1
17 Loop While SheetExist(varSheetName(0) & CStr(intIndex), objWB.Name) = True

18 With objWB
19 For intCount = 0 To UBound(varSheetName)
20 ThisWorkbook.Sheets(varSheetToCopy(intCount)).Copy _
    after:=.Sheets(.Sheets.Count)
21 .Sheets(.Sheets.Count).Name = varSheetName(intCount) & CStr(intIndex)
22 .Sheets(varSheetName(intCount) & CStr(intIndex)).UsedRange = _
    .Sheets(varSheetName(intCount) & CStr(intIndex)).UsedRange.Value
23 With .VBProject.VBComponents(.Sheets(varSheetName(intCount) & _
    CStr(intIndex)).CodeName).CodeModule
24 .DeleteLines 1, .CountOfLines
25 End With
26 Next
27 End With

28 If Not blnWasOpen Then
29 objWB.Close True
30 Else
31 objWB.Save
32 End If

33 ThisWorkbook.Activate

ErrExit:
34 GMS True
35 If Err.Number > 0 Then
36 MsgBox "Es ist ein Fehler in Zeile " & CStr(Erl) & " aufgetreten!" & _
    vbLf & vbLf & "Fehlernummer:" & vbTab & Err.Number & vbLf & "Fehlerquelle:" & _
    vbTab & Err.Source & vbLf & "Beschreibung:" & vbTab & Err.Description & _
    Space(25), vbExclamation, "Fehler"
37 End If
38 Err.Clear
End Sub

Private 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 Modus Then
        .Calculation = IIf(lngCalc <> 0, lngCalc, xlCalculationAutomatic)
    Else
        lngCalc = .Calculation
        .Calculation = xlCalculationManual
    End If
    .Cursor = IIf(Modus, -4143, 2)
    .CutCopyMode = False
End With

End Sub

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


Gruß Sepp



Anzeige
AW: etwas kürzer
20.06.2008 22:50:48
Fritz_W
Hallo Sepp,
vielen Dank, einfach Klasse!
Gruß
Fritz

303 Forumthreads zu ähnlichen Themen

Fehler beim Kopieren von Tabelle in neue Datei
Tabelle

Guten Abend
Aus einer Datei möchte ich gerne eine Tabelle via "Verschieben oder kopieren" in eine neue Arbeitsmappe verschieben (mittels Aktivieren des Kästchens "Kopie erstellen").
Das ist in der Regel auch kein Problem. Doch heute scheitere ich bei einer bestimmten Datei daran, da bei...
28.08.2008 17:48:35
Thread-ID: 1005548
3 Beiträge
Anzeige
Tabelle in neue Datei speichern
Robert

Hallo,
kann mir bitte jemand helfen...bin am verzweifeln ;-)
Ein Tabellenblatt der geöffneten Datei sollte in eine neue Datei gespeichert werden - und das mit dem Zellinhalt eines anderen Tabellenblattes derselben Datei als Dateiname. Sollte eine Datei mit demselben Namen bereits besteh...
26.12.2008 10:18:00
Thread-ID: 1035274
4 Beiträge
tabellenblatt in Excel mit neuer Instanz kopieren
chris

Hallo zusammen,
ich habe eine frage.Vielleicht könnt ihr mir helfen.
ich versuche eine Auswertung zu erstellen und diese soll in eine neue Instanz von Excel kopiert werden.
Aber irgendwie klappt das nicht :(
Ich habe unten einen code angefügt damit ich als erstes eine neue Insta...
10.02.2009 13:39:15
Thread-ID: 1049055
8 Beiträge
Anzeige
Makro per Makro in neue Datei kopieren
miss18

Guten Morgen alle zusammen,
ich hoffe Ihr könnt mir noch einmal helfen.
Ich habe folgendens Makro (siehe SUB AbteilungX) für die Freigabe der Dokumentenübersicht für eine bestimmte Abteilung. Diese Freigabe-Makros sind in einer Exceldatei (.xls). Wenn ich die Datei sozusagen freigebe, w...
02.07.2009 10:42:12
Thread-ID: 1085869
7 Beiträge
Tabellen in Datei kopieren
Tobiax

Hallo!
Ich möchte gerne einige meiner Tabellen per Makro in eine Andere Datei kopieren.
Allerdings sollen nur die Werte und das Format in den 4 Tabellenblätter übernommen werden. Die Formeln nicht.
Die beiden Dateien liegen IMMER im selben Ordner.
Kann mir jmd helfen?
Toby ....
25.07.2009 09:06:13
Thread-ID: 1091116
4 Beiträge
Blätter in neue Datei kopieren
Tobiax

Hallo!
Ich möchte aus der Datei "x.xls", 5 bestimmte Tabellenblätter (A, B, C, D, E) in die Datei "y.xls" kopiert haben.
Wie bekomme ich das per Makro hin?
Toby ...
P.S.: Zur Not kann mit den 5 Blättern auch neue Datei generiert werden mit dem Namen "y.xls".
27.07.2009 11:48:47
Thread-ID: 1091559
6 Beiträge
VBA:einzelnes Blatt in neuer Datei speichern +mehr
habneFrage

Hallo liebes Forum! Ich habe mich hier heute mal angemeldet, da ich schon seit längerer Zeit an einem Problem arbeite aber keine Lösung gefunden habe. Ich habe mit VBA nicht besonders viel am Hut, dafür kann ich mit anderen Dingen in Excel schon besser umgehen. Nun aber zu meinen Fragen:
Ic...
30.10.2009 08:03:49
Thread-ID: 1113145
14 Beiträge
Tabellenblatt als Datei speichern
Murat

Was stimmt bei dem VBA code nicht bekomme Fehler bei kompilieren variable nicht definert
Ich möchte die einzeln Tabellenblätter als Datei Speichern. ich habe 20 Tabellenblätter in einer Datei aus der sollen 20 Dateien werden. Dateiname steht immer in Zelle i2 des jeweiligen tabellenblattes....
19.01.2010 16:27:42
Thread-ID: 1131114
6 Beiträge
Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Jetzt das Excel-Portal bewerten: Deine Stimme zählt!

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige
Archiv - Verwandte Themen
Forumthread
Beiträge
2
5
3
7
4
6
3
5
13
5
5
7
5
2
13
1
4
6
19
7
1
6
2
12
1