AW: Inhalte einfügen... (Werte)... noch offen!
05.07.2011 21:43:40
chris58
Hallo !
Ich habe hier einen Code der kopiert dir mittels VBA die Daten in die jeweilige Tabelle der gleichen Datei.
Du mußt sie nur anpassen. Der zweite Code sichert dir die Daten der einzelnen Tabellen in einen Ordner deiner Wahl (Pfad muß angepaßt werden). Ich hoffe du kannst damit was anfangen. Leider sichert der Code nicht die Tabelle, aus der sie aufgerufen wird, sondern nur die weiteren in der Datei befindlichen Tabellenblätter. Ich habe die Code von hier, also die laufen einwandfrei. Du mußt diese Code in deine Tabelle einfügen und mittels Button aufrufen. Hoffe es hilft dir weiter.
lg
chris58
Der erste Code zum kopieren:
Private Sub CommandButton1_Click()
'Bedingtes Kopieren
EinfügeZeile = 3 ' Ab dieser Zeile weden die Daten eingefügt
TabellenBeginn = 3 ' Ab hier beginnt die Suche nach ...
TabName = "Bilanzarbeiten" ' In dieses Tabellenblatt wird kopiert
TabName2 = "Saldenliste sowie alle Buchung" ' Aus diesem Tabellenblatt wird kopiert
Application.ScreenUpdating = False ' Bildschirmanzeige ausschalten
' Hier kann die Grösse der zu prüfenden Tabelle angegeben werden
Tabellengrösse = 4000
'Bedingung prüfen und kopieren
For Zeile = TabellenBeginn To Tabellengrösse
If Worksheets(TabName2).Cells(Zeile, 4) = "WEK" Or Worksheets(TabName2).Cells(Zeile, _
_
_
_
_
4) = "WEK" Then
ZelleA = Worksheets(TabName2).Cells(Zeile, 1)
ZelleB = Worksheets(TabName2).Cells(Zeile, 2)
ZelleE = Worksheets(TabName2).Cells(Zeile, 5)
ZelleF = Worksheets(TabName2).Cells(Zeile, 6)
ZelleL = Worksheets(TabName2).Cells(Zeile, 12)
ZelleR = Worksheets(TabName2).Cells(Zeile, 18)
Worksheets(TabName).Cells(EinfügeZeile, 1) = ZelleA
Worksheets(TabName).Cells(EinfügeZeile, 2) = ZelleB
Worksheets(TabName).Cells(EinfügeZeile, 3) = ZelleE
Worksheets(TabName).Cells(EinfügeZeile, 4) = ZelleF
Worksheets(TabName).Cells(EinfügeZeile, 5) = ZelleL
Worksheets(TabName).Cells(EinfügeZeile, 6) = ZelleR
EinfügeZeile = EinfügeZeile + 1
End If
Next Zeile
Application.ScreenUpdating = True 'Bildschirmanzeige wieder einschalten
End Sub
Sub Sichern()
Dim i As Integer
Application.ScreenUpdating = False
With ThisWorkbook
For i = 2 To .Worksheets.Count
If .Sheets(i).Visible Then
.Sheets(i).Copy
With ActiveSheet
.Cells.Copy
.Range("A1").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
.Parent.SaveAs Filename:= _
"C:\Dokumente und Einstellungen\Eigene\Desktop\Summe\Monatslisten\" _
& " Monatsliste_" & Date & "_" & .Name & ".xls", _
FileFormat:=xlNormal, Password:="", WriteResPassword:="", _
ReadOnlyRecommended:=False, CreateBackup:=False
.Parent.Close
End With
End If
Next i
.Sheets(1).Select
End With
MsgBox "Dateien wurden gespeichert"
End Sub