excel makro zeilen kopieren
10.07.2003 13:41:53
arnold
soll aus verschiedenen blättern derselben datei immer verschiedene felder in ein neues blatt kopieren:
z.b.:
1.blatt:
nummer.name.nachname
1 anton meier
2 gernot müller
2.blatt:
nummer.name.nachname
3 martin geier
4 willi eigner
dies soll auf dem neuen blatt so aussehen:
nummer.name.nachname
1 anton meier
2 gernot müller
3 martin geier
4 willi eigner
hätte folgenden code anzubieten:
Sub Auswert()
' Auswertung von Sysdata Konvertierungsfiles
' Suchkriterium: Kontobezeichnung
' Ergebnis: darauf kontierte Stunden & Aufgaben werden gesammelt
Application.ScreenUpdating = False
Kontierungsfile = Application.GetOpenFilename(, , "Sysdata MA-spez. Kontierungsfiles")
If Kontierungsfile = False Then ' Benutzer hat abgebrochen
Exit
Sub
End If
directory = CurDir()
concatfile = InputBox("Wie soll das Ergebnis-File heissen?")
suchstring = InputBox("Bitte zu suchende Kontobezeichnung eingeben")
'Protokolldatei für MA-Name anlegen
Set protbook = Workbooks.Add
Set newbook = Workbooks.Add
newbook.Activate
Range("A1") = "Konto:"
Range("B1") = suchstring
Range("A2") = "MA"
Range("B2") = "Thema1"
Range("C2") = "Thema2"
Range("D2") = "Stunden"
Range("A2").Activate
z_reihe = 3
Set dateisuche = Application.FileSearch
With dateisuche
.LookIn = directory
If .Execute() = 0 Then
MsgBox "Verzeichnis ist leer"
End If
MsgBox ("Es werden " & .FoundFiles.Count & " Mitarbeiterkontierungsfiles bearbeitet")
For i = 1 To .FoundFiles.Count
Kontierungsfile = .FoundFiles(i)
Workbooks.Open FileName:=Kontierungsfile, UpdateLinks:=0
MaBook = ActiveWorkbook.Name
ActiveSheet.Unprotect ("Projekt00")
'MA-Name/Personalnr. lesen
Ma_name = Range("C4").Value
If Ma_name = "" Then
Ma_name = ""
End If
'Ende der Daten suchen
Range("A7").Select
Selection.End(xlDown).Activate
reihe = ActiveCell.Row
For r = 2 To reihe
' Daten suchen
If InStr(Cells(r, 3).Value, suchstring) Then
Kontobez = Cells(r, 3)
'zu kopierende Daten selektieren
For c = 7 To 40
If Cells(r, c) <> "" Then
Aufwand = Cells(r, c)
Thema1 = Cells(4, c)
Thema2 = Cells(5, c)
newbook.Activate
Cells(z_reihe, 1) = Ma_name
Cells(z_reihe, 2) = Thema1
Cells(z_reihe, 3) = Thema2
Cells(z_reihe, 4) = Aufwand
Cells(z_reihe, 5) = Kontobez
z_reihe = z_reihe + 1
Workbooks(MaBook).Activate
End If
Next c
End If
Next r
' Kontierungsfile schließen
Workbooks(MaBook).Activate
Application.CutCopyMode = False
Workbooks(MaBook).Close Savechanges:=False
'Prokolleintrag durchühren
protbook.Activate
Range("A" & i).Value = Ma_name
Range("B" & i).Value = Personalnr
Next i
End With
' Ergebnis-File zurückschreiben
newbook.Activate
ActiveWorkbook.SaveAs FileName:= _
directory & "\" & concatfile, FileFormat:=xlWorkbookNormal, CreateBackup:=False
newbook.Close Savechanges:=False
'Protokollfile schreiben
protbook.Activate
ActiveWorkbook.SaveAs FileName:=directory & "\" & concatfile & "_Prot", FileFormat:=xlWorkbookNormal, CreateBackup:=False
protbook.Close Savechanges:=False
' Auf Makrofile zurückschalten
Workbooks("Auswert.xls").Worksheets("Tabelle1").Activate
Application.ScreenUpdating = True
End
Sub
dieser kann das bei verschiedenen dateien, bin aber leider so unfähig in vba dass ich das nicht mal umschreiben kann.
wäre für jede hilfe dankbar,
mfg arnold