Live-Forum - Die aktuellen Beiträge
Datum
Titel
28.03.2024 21:12:36
28.03.2024 18:31:49
Anzeige
Archiv - Navigation
1032to1036
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

Liste mit Kostenstellen durchlaufen u. abspeichern

Liste mit Kostenstellen durchlaufen u. abspeichern
25.12.2008 11:29:01
Bernd
Liebe Freaks,
ich wäre Euch sehr dankbar für ein Makro, dass nachstehende Aufgabe abarbeitet:
Ich bitte um ein Makro, dass alle Gültigkeitswerte aus der Zelle C13 durchläuft und nach jeder Auswahl !A" bis "H" den Wert unter "C:\Kostenstellenblätter" abspeichert.
Mit anderen Worten:
alle Gültigkeitswerte von A bis H aufrufen, per Sverweis aktualisieren und dann für die einzelnen Kostenstellenblätter "A" bis "H" jeweils unter dem Dateinamen "A.xls"; B.xls" ; "C.xls" … auf Verzeichnis "C:\Kostenstellenblätter" abspeichern.
Beispieldatei: https://www.herber.de/bbs/user/57868.xls
Grüße und Danke!!!!
Bernd

12
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Liste mit Kostenstellen durchlaufen u. abspeichern
25.12.2008 12:13:00
Tino
Hallo,
hab eich dich richtig verstanden, müsse es so gehen.
kommt als Code in Tabelle1
Option Explicit 
 
Private Sub Worksheet_Change(ByVal Target As Range) 
Dim Bereich As Range 
Dim Zelle As Range 
 If Intersect(Target, Range("C13")) Is Nothing Then Exit Sub 
     
    Set Bereich = Range("C23", Cells(Rows.Count, "c").End(xlUp)) 
     With Application 
      .ScreenUpdating = False 
      .DisplayAlerts = False 
        For Each Zelle In Bereich 
         Range("C14").FormulaR1C1 = "=VLOOKUP(""" & Zelle.Text & """,Tabelle2!R[9]C:R[17]C[1],2,0)" 
         Tabelle1.Copy 
         'Datei speichern, ist diese vorhanden wird sie überschrieben 
         ActiveWorkbook.SaveAs ("C:\Kostenstellenblätter\" & Zelle.Text & ".xls") 
         ActiveWorkbook.Close False 
        Next Zelle 
      .DisplayAlerts = True 
      .ScreenUpdating = True 
     End With 
 
End Sub 
 


Gruß Tino

Anzeige
@Tino
25.12.2008 12:37:23
Bernd
Hallo Tino,
vielen Dank für dein Makro.
Würdest du dich bitte noch einmal meines Problems annehmen? Es klappt nur zu 98 %...
Ich habe dein Makro in die Tabelle 1 eingefügt. Es klappt auch fast, nur ein kleines Problem:
Wenn ich z.B. den Eintrag "A" wähle, wird zwar das Makro durchgelaufen und die Blätter A bis H mit den Dateinamen "A" ... "H" abgespeichert, nur haben alle Blätter dann in der Zelle C13 die Kostenstelle "A" stehen. Das Blatt A sollte A in Zelle C13 stehen haben und das Blatt B sollte "B" in Zelle C13 stehen haben etc.
Beispiel Datei "D.xls" : https://www.herber.de/bbs/user/57870.xls (mit Makro)
Vielen Dank!!
Grüße
Bernd
Anzeige
ok. noch ein Versuch.
25.12.2008 12:51:06
Tino
Hallo,
teste mal so.
Microsoft Excel Objekt Tabelle1
Option Explicit 
 
  
Private Sub Worksheet_Change(ByVal Target As Range) 
Dim Bereich As Range 
Dim Zelle As Range 
Dim MerkWert 
 If Intersect(Target, Range("C13")) Is Nothing Then Exit Sub 
      
    Set Bereich = Range("C23", Cells(Rows.Count, "c").End(xlUp)) 
     With Application 
      MerkWert = Target.Value 
      .ScreenUpdating = False 
      .EnableEvents = False 
      .DisplayAlerts = False 
         
        For Each Zelle In Bereich 
         Target.Value = Zelle.Value 
         Tabelle1.Copy 
         'Datei speichern, ist diese vorhanden wird sie überschrieben 
         ActiveWorkbook.SaveAs ("C:\Kostenstellenblätter\" & Zelle.Text & ".xls") 
         ActiveWorkbook.Close False 
        Next Zelle 
        
       Target.Value = MerkWert 
      .EnableEvents = True 
      .DisplayAlerts = True 
      .ScreenUpdating = True 
     End With 
  
End Sub 
 


Gruß Tino

Anzeige
AW: @Tino
25.12.2008 12:54:00
Tino
Hallo,
möchtest Du die Formel nicht, geht diese Version
Option Explicit

 
Private Sub Worksheet_Change(ByVal Target As Range)
Dim Bereich As Range
Dim Zelle As Range
Dim MerkWert
 If Intersect(Target, Range("C13")) Is Nothing Then Exit Sub
     
    Set Bereich = Range("C23", Cells(Rows.Count, "c").End(xlUp))
     With Application
      MerkWert = Target.Value
      .ScreenUpdating = False
      .EnableEvents = False
      .DisplayAlerts = False
        
        For Each Zelle In Bereich
         Target.Value = Zelle.Value
         Tabelle1.Copy
         ActiveSheet.UsedRange.Value = ActiveSheet.UsedRange.Value
         'Datei speichern, ist diese vorhanden wird sie überschrieben 
         ActiveWorkbook.SaveAs ("C:\Kostenstellenblätter\" & Zelle.Text & ".xls")
         ActiveWorkbook.Close False
        Next Zelle
       
       Target.Value = MerkWert
      .EnableEvents = True
      .DisplayAlerts = True
      .ScreenUpdating = True
     End With
 
End Sub


Gruß Tino

Anzeige
AW: @Tino
25.12.2008 13:09:00
Bernd
Hi Tino,
ich muss jetzt leider ins Auto und Richtung Nordbayern zu den Schwiegereltern fahren. Sonst kriege ich Ärger mit der "Regierung", meiner Frau. Konnte leider noch nicht testen.
Ich kann mich leider erst in zwei oder drei Tagen wieder einloggen...
Ich will halt gerne, dass alle KSt der Liste C23:C31 in das Feld C13 geschrieben werden, per Sverweis Wert dazu und dann unter dem Namen, der in C13 steht, abgespeichert wird auf c;\Kostenstellenblätter.
Schaust du mal...? Tausend Dank vorab. https://www.herber.de/bbs/user/57871.xls
Grüße
Bernd
Anzeige
AW: @Bernd
25.12.2008 13:33:00
Tino
Hallo,
Du machst Urlaub bei den Schwiegereltern und ich soll arbeiten? ;-)
Nee, nee ich warte mal schön bis Du wieder da bist.
Gruß Tino
AW: @Tino - melde mich zurück :-)
25.12.2008 20:26:00
Bernd
Hi Tino,
Schwiegereltern sind leider kein Urlaub. Aber die haben einen riesen Fortschritt gemacht undhaben Internet!!!! Kann mich doch noch anfreunden :-))
Ich melde mich sozusagen wieder zur Arbeit zurück :-))
Danke voprab!!
Grüße
Bernd
AW: @Tino - melde mich zurück :-)
25.12.2008 20:51:00
Tino
Hallo,
haben Deine Schwiegereltern auch Excel zum testen?
Bin auch unterwegs, schreibe vom Pocket.
Gruß Tino
AW: @Tino nochmals bitte
26.12.2008 17:25:39
Bernd
Hi Tino,
erst einmal vielen Dank für deinen Hilfe. Du hast mir super damit geholfen.
Darf ich noch zwei Fragen stellen?
1. Es wird nur die Tabelle1 kopiert. Ich habe aber in den "echten" Blättern auch eine Seite 2 namens "Grafik". Die wird im aktullen Code - der super funktionert!!!! - leider nicht mitkopiert.
2. Kannst du mir bitte zusätzlich zu Punkt 1 einen Code bereitstellen bzw den Code aus Punkt 1 so abändern, dass ich diesen mit nicht mit "Worsheet_Change" auslöse sondern per Button starte (m.W. Code in einem Modul) ?

Private Sub Worksheet_Change(ByVal Target As Range)
Dim Bereich As Range
Dim Zelle As Range
Dim MerkWert
If Intersect(Target, Range("C13")) Is Nothing Then Exit Sub
Set Bereich = Range("C23", Cells(Rows.Count, "c").End(xlUp))
With Application
MerkWert = Target.Value
.ScreenUpdating = False
.EnableEvents = False
.DisplayAlerts = False
For Each Zelle In Bereich
Target.Value = Zelle.Value
Tabelle1.Copy
'Datei speichern, ist diese vorhanden wird sie überschrieben
ActiveWorkbook.SaveAs ("C:\Kostenstellenblätter\" & Zelle.Text & ".xls")
ActiveWorkbook.Close False
Next Zelle
Target.Value = MerkWert
.EnableEvents = True
.DisplayAlerts = True
.ScreenUpdating = True
End With
End Sub


Ich habe viel von Dir mit dem Code gelernt. Danke nochmals.
PS: Ich habe meine Laptop dabei und bin damit bei den Schwiegereltern ins Internet gegangen.
Herzliche Grüße
Bernd

Anzeige
AW: @Tino nochmals bitte
26.12.2008 17:50:31
Tino
Hallo,
so müsste es gehen, den Tabellennamen müsstest Du im Code eventuell noch anpassen.
Zeichne Dir einen Button und weise diesem dieses Makro zu.
Modul Modul1
Option Explicit 
Sub Tabellen_speichern() 
Dim Bereich As Range 
Dim Zelle As Range 
Dim MerkWert 
  
      
    Set Bereich = Range("C23", Cells(Rows.Count, "c").End(xlUp)) 
     With Application 
      MerkWert = Range("C13").Value 
      .ScreenUpdating = False 
      .EnableEvents = False 
      .DisplayAlerts = False 
         
        For Each Zelle In Bereich 
          
         Range("C13").Value = Zelle.Value 
     
'*********diese Tabellen werden kopiert, eventuell Name anpassen *********** 
         Sheets(Array("Tabelle1", "Grafig")).Copy 
             
            With ActiveWorkbook 
               'Datei speichern, ist diese vorhanden wird sie überschrieben 
               .SaveAs ("C:\Kostenstellenblätter\" & Zelle.Text & ".xls") 
               'neue Datei schließen 
               .Close False 
            End With 
         
        Next Zelle 
        
       Range("C13").Value = MerkWert 
      .EnableEvents = True 
      .DisplayAlerts = True 
      .ScreenUpdating = True 
     End With 
  
End Sub 
 
 


Gruß Tino

Anzeige
AW: @Tino : tausend Dank an Dich!!!!!
30.12.2008 10:43:00
Bernd
Hi Tino,
dein Code hat wunderbar geklappt. Ich bin dir sehr sehr dankbar. Du hast mir mit deinem Code meine Arbeit wahnsinnig erleichtert. Vielen herzlichen Dank noch einmal.
Mach's gut in 2009 !
Grüße
Bernd
Danke für die positive Rückmeldung oT.
30.12.2008 12:37:00
Tino

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige