Thema Datum  Von Nutzer Rating
Antwort
01.06.2017 12:24:48 Marcel
NotSolved
Blau Zusammenführung von 2 Makros
01.06.2017 13:34:24 Gast50142
NotSolved
02.06.2017 13:57:13 Gast35502
NotSolved
02.06.2017 14:16:21 Marcel
NotSolved
02.06.2017 15:43:30 Gast77879
NotSolved
03.06.2017 16:41:45 Marcel
NotSolved

Ansicht des Beitrags:
Von:
Gast50142
Datum:
01.06.2017 13:34:24
Views:
837
Rating: Antwort:
  Ja
Thema:
Zusammenführung von 2 Makros

Moin! Ist noch keine Lösung aber mal ein lesbarer Text: Hoffe mal das alles so in der Reihe ist, wie bei dir. So findet sich ggf. eher ien Helfer. VG

Hallo, ich möchte gerne 2 noch separate Makros zusammenführen und diese nacheinander laufen lassen. Könnt ihr mir hier behilflich sein.
1. Makro: Tabellenblatt wird nach einem Kriterium in einzelne Tabellenblätter gesplittet
2. Makro: Einzelne Tabellenblätter werden dann an einem Ort definierten Ort gespeichert Hier soll es jedoch dann so sein, dass die im ersten Makro erstellten Tabellenblätter nicht in der Datei als neue Tabellenblätter bleiben, sondern nach dem Speichern an dem definierten Ort wieder gelöscht werden. Über eure Info wäre ich euch sehr dankbar. Die beiden Makros sehen wie folgt aus:
1.

1
2
3
4
5
6
7
8
9
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
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
Option Explicit
Sub KritToSheet()
Dim objShSource As Worksheet, objSh As Worksheet
Dim rng As Range, rngCopy As Range
Dim varTemp As Variant
Dim strFind As String, strFirst As String
Dim lngLast As Long, lngAct As Long
Dim rngCol As Range, intCol As Integer
 
On Error Resume Next
Set rngCol = Application.InputBox("Markieren Sie eine Zelle in der" & vbLf & _ "gewünschten Spalte! (Kriterium)", "Tabelle aufteilen", ActiveCell.Address, Type:=8)
 
If rngCol Is Nothing Then Exit Sub
 
intCol = rngCol(1).Column
On Error GoTo ErrExit
With Application
    .ScreenUpdating = False
    .EnableEvents = False
    .DisplayAlerts = False
    .Calculation = xlCalculationManual
    .Cursor = xlWait
End With
rngCol.Parent.Copy After:=Sheets(Sheets.Count)
Set objShSource = Sheets(Sheets.Count)
With objShSource
    lngLast = .Cells(Rows.Count, intCol).End(xlUp).Row
    lngAct = lngLast
    Do While lngAct > 1
        strFind = .Cells(2, intCol)
        Set rngCol = .Range(.Cells(2, intCol), .Cells(lngAct, intCol))
        Set rng = rngCol.Find(what:=strFind, lookat:=xlWhole)
 
        If Not rng Is Nothing Then
            strFirst = rng.Address
            Do
                If rngCopy Is Nothing Then
                    Set rngCopy = .Rows(rng.Row)
                Else
                    Set rngCopy = Union(rngCopy, .Rows(rng.Row))
                End If
                 
                Set rng = rngCol.FindNext(rng)
            Loop While Not rng Is Nothing And strFirst <> rng.Address
        End If
         
        If Not rngCopy Is Nothing Then
            Set objSh = Worksheets.Add(After:=Sheets(Sheets.Count))
            On Error Resume Next
            objSh.Name = strFind
            If Err.Number <> 0 Then
                objSh.Name = strFind & Format(Now, " hhmmss")
                Err.Clear
            End If
         
            On Error GoTo ErrExit
            rngCopy.Copy objSh.Cells(2, 1).PasteSpecial xlValues
            objSh.Cells(2, 1).PasteSpecial xlFormats
            Application.CutCopyMode = False
            objShSource.Rows(1).Copy objSh.Rows(1)
            rngCopy.Delete
            Set rngCopy = Nothing
            Set objSh = Nothing
        End If
         
        lngAct = .Cells(Rows.Count, intCol).End(xlUp).Row
    Loop
    .Delete
End With
 
ErrExit:
Set objShSource = Nothing
Set rngCol = Nothing
With Application
    .ScreenUpdating = True
    .EnableEvents = True
    .DisplayAlerts = True
    .Calculation = xlCalculationAutomatic
    .Cursor = xlDefault
End With
 
End Sub

und das zweite makro

1
2
3
4
5
6
7
8
9
10
11
12
13
Sub alle_Tab_als_Datei()
Dim neuname As String
Dim pfad As String
Dim i As Integer
 
For i = 2 To ActiveWorkbook.Sheets.Count
    neuname = Sheets("Upload").Range("A11") & " " & Sheets(i).Name
    pfad = "C:\Users\xxx.xxx\Desktop\"
    Sheets(i).Copy
    ActiveWorkbook.SaveAs pfad & neuname
    ActiveWorkbook.Close
Next
End Sub

 


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
01.06.2017 12:24:48 Marcel
NotSolved
Blau Zusammenführung von 2 Makros
01.06.2017 13:34:24 Gast50142
NotSolved
02.06.2017 13:57:13 Gast35502
NotSolved
02.06.2017 14:16:21 Marcel
NotSolved
02.06.2017 15:43:30 Gast77879
NotSolved
03.06.2017 16:41:45 Marcel
NotSolved