Office Forum
www.Office-Loesung.de
Access :: Excel :: Outlook :: PowerPoint :: Word :: Office :: Wieder Online ---> provisorisches Office Forum <-
automatisches speichern fortlaufend
Gehe zu Seite Zurück  1, 2
zurück: Eintrag davor weiter: SQL-Abfrage in VBA erstellen Unbeantwortete Beiträge anzeigen
Neues Thema eröffnen   Neue Antwort erstellen     Status: Bitte Status wählen ! Facebook-Likes Diese Seite Freunden empfehlen
Zu Browser-Favoriten hinzufügen
Autor Nachricht
Darwin
Office-Anwender


Verfasst am:
24. Mai 2005, 12:57
Rufname:

VIELEN VIELEN DANK - VIELEN VIELEN DANK

Nach oben
       

Vielen Vielen Dank,

also ich hab den Code ein bisschen verändert, siehe anbei, sonst hat er
nicht funktioniert, jetzt tuts, ach und das mit den 10000 Zeilen ist nicht
weiter wichtig, ist so schon mehr als perfekt, vielen dank!!

Code:

Sub Kopiereneinfügen()
'
' bezieht aus dieser Datei Format aus einzigen Blatt für
' die neuen Blätter in den Neuen Dateien
' Datenliefernde datei frei wählbar
' für jedes Blatt in dieser abfrage ob dieses bearbeitet werden soll
' wenn ja wird hierfür eine Datei erstellt
' in diese werden 4 Spalten bis maximal 10000 Zeilen kopiert
' danach neue Datei usw.
'
   Dim MaxLine As Long: MaxLine = 65536
   Dim SLine As Long 'schreib zeile start 2
   Const MaxDoo = 9999
   Dim Doo As Long
   Dim I As Long, ll As Long, toDo As Long, vll As Long
   Dim J As Integer ' schleifenzähler
   Dim M As Integer
   Dim s As Integer 'zum Sheet abarbeiten
   Dim Z As Integer ' zähler 1 bis 7
   Dim x As String
   Dim Blattnamen As String
   Dim sDateiName As String, sDateiNeu As String, sWorkBlatt As String
   Dim sZelle(4) As String ' Basisspalte zelle1 2 3 4
   Dim Del As Boolean
   Dim sVonSp(4) As String
   sVonSp(1) = "A": sVonSp(2) = "B": sVonSp(3) = "C": sVonSp(4) = "D"
   Dim sNachSp(4) As String ' Zielspalte B C E F
   sNachSp(1) = "B": sNachSp(2) = "C": sNachSp(3) = "E": sNachSp(4) = "F"
   
   If ThisWorkbook.Sheets.Count > 1 Then
    MsgBox "Sie haben das Makro Kopiereneinfügen gestartet !!!" & vbCrLf & _
           "Dieses Makro wird aus der Basisdatei (name egal) gestartet und diese darf nur ein Blatt enthalten" & vbCrLf & _
           " und zwar D A S   Musterblatt (name egal) aus dem die Zeile 1 und die Spalten ADGH entnommen werden.", vbCritical, "ROLA informiert"
    Exit Sub
   End If
'# aus welcher Datei kommen die Daten
   x = Left(ThisWorkbook.Path, 3)
   ChDrive x
   ChDir ThisWorkbook.Path
   x = Application.GetOpenFilename("Exceldateien(*.xls), *.xls", , "Welche Datei soll als Basis dienen?")
   If x = "" Then Exit Sub
   If InStr(1, x, "\") = 0 Then Exit Sub
   If DateiOffen(x) = False Then
       Workbooks.Open Filename:=x, UpdateLinks:=0, ReadOnly:=Del
   Else
        Workbooks(x).Activate
   End If
   sDateiName = ActiveWorkbook.Name
   SLine = 2

'# arbeitet ein blatt nach dem anderen ab
For s = 1 To Workbooks(sDateiName).Sheets.Count
BlattAbarbeiten:
   On Error GoTo 0
   Workbooks(sDateiName).Activate
   Sheets(s).Select
    x = MsgBox( _
    "Soll das Blatt " & Sheets(s).Name & " abgearbeitet werden ? JA/NEIN " & vbCrLf & _
    "Wollen Sie keines mehr abarbeiten dann Abbrechen" & vbCrLf _
    , vbYesNoCancel + vbQuestion, "Was soll mit dem Blatt " & Sheets(s).Name & " geschehen?")
    If x = "2" Then Exit Sub
    If x = "6" Then '6 = ja 7 = nein 2 = Abbrechen
        sWorkBlatt = Sheets(s).Name
    If x = "7" Then
        GoTo nextSheet
    End If

    For J = 1 To 4
spalteEingeben:
        sZelle(J) = InputBox("Bitte Buchstabe für Spalte " & sVonSp(J) & " angeben.", "Nur Buchstaben zulässig ")
        If sZelle(J) = "" Then Exit Sub
        If fSpaltenBuchstabenTesten(sZelle(J)) = False Then
            Beep
            GoTo spalteEingeben
        End If
    Next J
    If fZeigNichtleere(sZelle(2)) = False Then MsgBox "Fehler in fZeigNichtleere"
    ll = 3
    vll = ll
    MaxLine = ActiveSheet.Range(sZelle(1) & "65536").End(xlUp).Row
    'MaxLine = ActiveSheet.Range(sZelle(1) & 1).End(xlDown).Row
    toDo = MaxLine - ll
    Z = -1
    sDateiNeu = ""
    Do While toDo > 0
        Z = Z + 1
        Doo = IIf(toDo < MaxDoo, toDo, MaxDoo)         sDateiNeu = Left(sDateiName, Len(sDateiName) - 4) & "_" & sWorkBlatt & "_VSR0" & Z & ".xls"                                           J = Application.SheetsInNewWorkbook                                           Application.SheetsInNewWorkbook = 1                                           On Error GoTo BlattAbarbeiten                                           Workbooks.Add.SaveAs Filename:=sDateiNeu                                           On Error GoTo 0                                           ActiveSheet.Name = Application.WorksheetFunction.Substitute(Date & " " & Time, ":", "_")                                           If fGrundgerüst(sDateiNeu) = False Then MsgBox "Error in Function  Grundgerüst", vbCritical, "Sebastian informiert"                                           Application.SheetsInNewWorkbook = J                                           Windows(sDateiName).Activate Sheets(sWorkBlatt).Select Range(sZelle(J) & ll & ":" & sZelle(J) & ll + Doo).Select Do Until Range(sZelle(J) & ll & ":" & sZelle(J) & vll + Doo).SpecialCells(xlCellTypeVisible).Count = Doo Or Doo + vll = MaxLine vll = vll + Doo - Selection.SpecialCells(xlCellTypeVisible).Count Range(sZelle(J) & ll & ":" & sZelle(J) & vll + Doo).Select Loop If vll + Doo > MaxLine Then
                vll = MaxLine - Doo
                Range(sZelle(J) & ll & ":" & sZelle(J) & vll + Doo).Select
            End If
           
            For J = 1 To 4
                Windows(sDateiName).Activate
                Sheets(sWorkBlatt).Select
                Range(sZelle(J) & ll & ":" & sZelle(J) & vll + Doo).SpecialCells(xlCellTypeVisible).Copy
                Windows(sDateiNeu).Activate
                Range(sNachSp(J) & SLine).Select
                Range(sNachSp(J) & SLine).PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
                    False, Transpose:=False
               
                If J <> 2 Then
                    ActiveSheet.Paste
                Else
                    'C
                    Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
                    False, Transpose:=False
                    Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:= _
                    False, Transpose:=False
                End If
            Next J
        toDo = toDo - Doo - 1 - vll + ll
        If Del = True Then
            Windows(sDateiName).Activate
            Sheets(sWorkBlatt).Select
            Rows(ll & ":" & vll + Doo).Select
            Application.CutCopyMode = False
            Selection.Delete Shift:=xlUp
        Else
            ll = vll + Doo + 1
            vll = ll
        End If
       
       
        Windows(sDateiNeu).Activate
        Columns("E:E").Select
        Selection.Replace What:="3", Replacement:="100", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False
        Selection.Replace What:="4", Replacement:="1000", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False
        Columns("F:F").Select
        Selection.Replace What:="PK", Replacement:="PAK", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False
        [a1].Select
        Windows(sDateiNeu).Activate
If sDateiNeu = "" Then GoTo nextSheet:
        ActiveSheet.Protect
        Workbooks(sDateiNeu).Save
        MsgBox "Die Daten wurden erfolgreich in " & sDateiNeu & " kopiert"
        Workbooks(sDateiNeu).Close SaveChanges:=True
    'es werden die nächsten maxdoo zeilen bearbeitet
    Loop

nextSheet:
If Workbooks(sDateiName).Sheets(sWorkBlatt).AutoFilterMode = True Then
    Workbooks(sDateiName).Sheets(sWorkBlatt).AutoFilterMode = False
End If
End If
Next s
End Sub

Public Function DateiOffen(Dateiname As String) As Boolean

    Dim I As Long
    DateiOffen = False
    Do While InStr(1, Dateiname, "\")
    Dateiname = Mid(Dateiname, InStr(1, Dateiname, "\") + 1, Len(Dateiname))
    Loop
    For I = 1 To Workbooks.Count
        'schreibt in direkt fenster
        Debug.Print Workbooks(I).Name
        If UCase(Workbooks(I).Name) = UCase(Dateiname) Then
            DateiOffen = True
            Exit Function
        End If
    Next
End Function
Public Function fSpaltenBuchstabenTesten(B As String) As Boolean
' Testet für fBuchstaben zu Spaltenzahl

Dim V As String 'Vergleichstring
Dim Wsf As WorksheetFunction
Set Wsf = Application.WorksheetFunction
V = "IV"
If B = "" Or Len(B) > Len(V) Then Exit Function

B = UCase(B)
If Wsf.Asc(B) < Wsf.Asc("A") Then Exit Function 'erste kleiner A
If Wsf.Asc(Right(B, 1)) < Wsf.Asc("A") Then Exit Function ' letzte kleiner A If Len(B) = Len(V) Then If Wsf.Asc(B) > Wsf.Asc(V) Then Exit Function 'erste > erste
    If Wsf.Asc(Right(B, 1)) > Wsf.Asc(Right(V, 1)) Then Exit Function ' letzte größer letzte
Else
    If Wsf.Asc(B) > Wsf.Asc("Z") Then Exit Function ' letzte größer Z
End If

fSpaltenBuchstabenTesten = True
End Function
Function fGrundgerüst(sDateiNeu As String) As Boolean
On Error GoTo Fehler
        Workbooks(sDateiNeu).Activate
        ThisWorkbook.Sheets(1).Range("A1:H2").Copy
        Range("a1").PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
                   
        ThisWorkbook.Sheets(1).Range("A1:H2").Copy
        Range("A1").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
       
        Range("B2, C2, E2, F2").ClearContents
        Range("A2:H2").AutoFill Destination:=Range("A2:H10000"), Type:=xlFillDefault
       
        ThisWorkbook.Sheets(1).Activate
        Cells.Select
        Selection.Copy
        Workbooks(sDateiNeu).Activate
        Cells.Select
        Selection.PasteSpecial Paste:=xlFormats, Operation:=xlNone, SkipBlanks:= _
            False, Transpose:=False
       
fGrundgerüst = True
Fehler:
End Function
Function fZeigNichtleere(Spalte As String) As Boolean    'sp(2)
On Error GoTo Fehler
    If ActiveSheet.AutoFilterMode = True Then
        ActiveSheet.AutoFilterMode = False
    End If
    Columns(Spalte).AutoFilter Field:=1, Criteria1:="<>"
fZeigNichtleere = True
Fehler:
End Function


Grüße Darwin
Darwin
Office-Anwender


Verfasst am:
31. Mai 2005, 08:55
Rufname:


Access - Access

Nach oben
       

Hallo Rola,

du kennst dich nicht rein zufällig auch noch mit access aus,
sollte das nämlich jetzt auch noch ins access importieren,
funktioniert aber leider nicht.

Gruß Darwin
Neues Thema eröffnen   Neue Antwort erstellen Alle Zeiten sind
GMT + 1 Stunde

Gehe zu Seite Zurück  1, 2
Diese Seite Freunden empfehlen

Seite 2 von 2
Gehe zu:  
Du kannst Beiträge in dieses Forum schreiben.
Du kannst auf Beiträge in diesem Forum antworten.
Du kannst deine Beiträge in diesem Forum nicht bearbeiten.
Du kannst deine Beiträge in diesem Forum nicht löschen.
Du kannst an Umfragen in diesem Forum nicht mitmachen.
Du kannst Dateien in diesem Forum nicht posten
Du kannst Dateien in diesem Forum herunterladen

Verwandte Themen
Forum / Themen   Antworten   Autor   Aufrufe   Letzter Beitrag 
Keine neuen Beiträge Excel Formeln: Automatisches Übertragen von Daten in Tabellenblätter 5 He!de 934 05. Mai 2007, 12:15
< Peter > Automatisches Übertragen von Daten in Tabellenblätter
Keine neuen Beiträge Excel Formeln: Excel 2003-- automatisches Berechnen 2 bonifazius 990 19. Apr 2007, 16:32
Gast Excel 2003-- automatisches Berechnen
Keine neuen Beiträge Excel Formeln: Wert auf Grund Bedingung in Feld A oder B speichern 0 dado1208 619 06. Apr 2007, 15:26
dado1208 Wert auf Grund Bedingung in Feld A oder B speichern
Keine neuen Beiträge Excel Formeln: Automatisches Einfügen einer Zeile wenn.... 0 soulchild7 409 22. März 2007, 17:27
soulchild7 Automatisches Einfügen einer Zeile wenn....
Keine neuen Beiträge Excel Formeln: SUCHE FORMEL.... automatisches einsetzten! 2 LENA_SIGU 598 20. Feb 2007, 17:17
Gast SUCHE FORMEL.... automatisches einsetzten!
Keine neuen Beiträge Excel Formeln: automatisches Ausführen eines Makros 1 Marvin_der_Koenig 1033 03. Jan 2007, 19:21
ransi automatisches Ausführen eines Makros
Keine neuen Beiträge Excel Formeln: Excel: Automatisches Ausfüllen von Zellen 4 merton 5780 15. Dez 2006, 11:32
merton Excel: Automatisches Ausfüllen von Zellen
Keine neuen Beiträge Excel Formeln: automatisches Datum in Zelle 2 DieFrohnatur 598 21. Nov 2006, 13:56
DieFrohnatur automatisches Datum in Zelle
Keine neuen Beiträge Excel Formeln: automatisches datum und freier text innerhalb einer zelle?? 2 cts_1 609 23. Jun 2006, 14:05
cts_1 automatisches datum und freier text innerhalb einer zelle??
Keine neuen Beiträge Excel Formeln: automatisches sortieren mit bezug auf anderen tabellenblatt 2 tobitobson 2041 22. Jun 2006, 10:18
tobitobson automatisches sortieren mit bezug auf anderen tabellenblatt
Keine neuen Beiträge Excel Formeln: Automatisches Berechnen der Klassenzugehörigkeit 2 Hubert22 1531 18. März 2006, 14:25
hubert22 Automatisches Berechnen der Klassenzugehörigkeit
Keine neuen Beiträge Excel Formeln: Automatisches Anzeigen einzelner Zellen bei aktuellem Datum 22 m.barth 2846 15. Feb 2006, 17:45
Moudi Automatisches Anzeigen einzelner Zellen bei aktuellem Datum
 

----> Diese Seite Freunden empfehlen <------ Impressum - Besuchen Sie auch: HTML Editoren Forum