wie besser? viele unnötige(?) For/Next-Schleifen
Ronald
ich habe hier (ganz schrecklichen?) Anfängercode.
Er läuft (schon mal schön), aber aufgrund der ganzen Schleifen auch recht langsam.
Hat jemand vielleicht Lust mir zu sagen bzw. die Richtung zu nennen, wie ich das besser/schöner/schneller lesen kann?
Ich hatte es anfangs mit mehr If und Then Verzweigungen versucht, aber da hatte ich mich wohl verzettelt. Brach immer irgendwo mit Fehlermeldung ab oder tat einfach nicht das, was ich wollte (böser Code, der ;-).
In einzelnen Schleifen nacheinander läuft es dann jetzt....
Aber diese ganzen For/Next-Schleifen, nacheinander...das muss doch anders gehen. Pro Zeile alles gleich auf einmal abarbeiten....
Ich versuche vom Blatt "septdat3.rpt" die Daten entsprechend Zeile für Zeile abzulaufen, umzubenennen, auf ein anderes Blatt zu kopieren und von dort aus auf wieder andere Blätter zu verteilen.
Ich denke, es würde viel Zeit einsparen, wenn ich die Schleifen richtig programmieren würde und nicht jedes mal alles von vorne durchlaufen wird in Einzelschritten, oder?
Im Falle der Daten dieses Monats sind es dann doch immerhin 18.000 Zeilen, die immer wieder von vorne durchlaufen werden....
Ich habe etwas Code zwischendurch gelöscht, da er unwichtig für meine Frage ist (Fehlermeldungen etc). Wie gesagt. Es funktioniert eigentlich ja auch...
Und: ja, hab grad gesehen, dass noch nicht alle Variablen sauber deklariert wurden....
Falls jemand Lust hat zu antworten: schon einmal ein großes Dankeschön im Voraus!!
Ronald
Sub Kopieren()
Dim colDate As Byte, colLength As Byte, colPhone As Byte, colStudyID As Byte
Dim tbName As String, tbNameNEU As String, tbTelefon As String
Dim A As Object
Dim LoLetzte1 As Long, LoLetzte2 As Long, LoLetzte3 As Long
Dim LoJ As Long, LoH As Long, LoI As Long, LoK As Long, LoL As Long
Dim strSuch1, strSuch2
Dim TextProjekt, ProjektNr, Leerzeichen
Dim loMonat As String, Mydate As Date
Dim RowProjekt As Long, NrProjekt As Long
Dim RowAULL As Long, RowAUMOB As Long, RowDELL As Long, RowDEMOB As Long
Dim CallLength As Integer
Dim tbProjekt As String, tbProjektkosten As String
Dim LastRow As Long, PathXls, FileNameXls, loMonatXls As String
tbName = "septdat3.rpt"
tbNameNEU = "septdat3 (bearbeitet)"
tbTelefon = "Telefonkosten"
PathXls = ThisWorkbook.Path
loMonatXls = Format(Now, "yyyy")
Application.ScreenUpdating = False
ThisWorkbook.Worksheets(tbName).Select
LoLetzte1 = ActiveSheet.UsedRange.SpecialCells(xlCellTypeLastCell).Row
ThisWorkbook.Worksheets(tbName).Cells(1, colStudyID + 1).Value = "ProjektNummer"
For LoH = 2 To LoLetzte1
If ThisWorkbook.Worksheets(tbName).Cells(LoH, 1).Value = "Date Count:" Then
ThisWorkbook.Worksheets(tbName).Cells(LoH, 1).EntireRow.Delete
End If
Next LoH
For LoI = 2 To LoLetzte1
If ThisWorkbook.Worksheets(tbName).Cells(LoI, 2).Value = "" And ThisWorkbook.Worksheets( _
tbName).Cells(LoI, 3).Value = "" Then
ThisWorkbook.Worksheets(tbName).Cells(LoI, 1).EntireRow.Delete
End If
Next LoI
For LoJ = 1 To LoLetzte1
If ThisWorkbook.Worksheets(tbName).Cells(LoJ, 1) "" Then
If IsDate(ThisWorkbook.Worksheets(tbName).Cells(LoJ, 1)) Then
ThisWorkbook.Worksheets(tbName).Cells(LoJ, 1).NumberFormat = "m/d/yyyy"
ThisWorkbook.Worksheets(tbName).Cells(LoJ, 1).Font.Bold = False
strSuch1 = ThisWorkbook.Worksheets(tbName).Cells(LoJ, 1).Value
Mydate = strSuch1
loMonat = Format(Mydate, "mmmm")
End If
End If
If ThisWorkbook.Worksheets(tbName).Cells(LoJ, 1).Value = "" Then
If ThisWorkbook.Worksheets(tbName).Cells(LoJ, 2).NumberFormat = "h:mm:ss AM/PM" Then
ThisWorkbook.Worksheets(tbName).Cells(LoJ, 1).Value = strSuch1
End If
End If
Next LoJ
LoLetzte2 = ActiveSheet.UsedRange.SpecialCells(xlCellTypeLastCell).Row
On Error Resume Next
For LoK = 1 To LoLetzte2
TextProjekt = ThisWorkbook.Worksheets(tbName).Cells(LoK, colStudyID).Value
Leerzeichen = InStr(1, Cells(LoK, colStudyID), " ")
ProjektNr = Left(TextProjekt, Leerzeichen - 1)
ThisWorkbook.Worksheets(tbName).Cells(LoK, colStudyID).Value = ProjektNr
Next LoK
ThisWorkbook.Worksheets(tbName).Range(Columns(colDate), Columns(colDate)).Select
Selection.Copy
ThisWorkbook.Worksheets(tbNameNEU).Select
Columns("A:A").Select
ActiveSheet.Paste
ThisWorkbook.Worksheets(tbName).Select
Range(Columns(colLength), Columns(colLength)).Select
Selection.Copy
ThisWorkbook.Worksheets(tbNameNEU).Select
Columns("B:B").Select
ActiveSheet.Paste
ThisWorkbook.Worksheets(tbName).Select
Range(Columns(colPhone), Columns(colPhone)).Select
Selection.Copy
ThisWorkbook.Worksheets(tbNameNEU).Select
Columns("C:C").Select
ActiveSheet.Paste
ThisWorkbook.Worksheets(tbName).Select
Range(Columns(colStudyID), Columns(colStudyID)).Select
Selection.Copy
ThisWorkbook.Worksheets(tbNameNEU).Select
Columns("D:D").Select
ActiveSheet.Paste
ThisWorkbook.Worksheets(tbNameNEU).Select
LoLetzte3 = ActiveSheet.UsedRange.SpecialCells(xlCellTypeLastCell).Row
For LoL = 2 To LoLetzte3
strSuch2 = ThisWorkbook.Worksheets(tbNameNEU).Cells(LoL, 4).Value
With ThisWorkbook.Worksheets("Projektnummern").Range("A1:A100")
Set A = .Find(strSuch2, LookIn:=xlValues)
If Not A Is Nothing Then
RowProjekt = A.Row
NrProjekt = ThisWorkbook.Worksheets("Projektnummern").Cells(RowProjekt, 2).Value
tbProjekt = ThisWorkbook.Worksheets("Projektnummern").Cells(RowProjekt, 3).Value
End If
End With
ThisWorkbook.Worksheets(tbNameNEU).Select
ThisWorkbook.Worksheets(tbNameNEU).Cells(LoL, 5).Value = NrProjekt
ThisWorkbook.Worksheets(tbNameNEU).Cells(LoL, 8).Value = loMonat
ThisWorkbook.Worksheets(tbNameNEU).Cells(LoL, 9).Value = tbProjekt
Next LoL
For LoL = 2 To LoLetzte3
ThisWorkbook.Worksheets(tbNameNEU).Select
TelNummer = ThisWorkbook.Worksheets(tbNameNEU).Cells(LoL, 3).Value
Call TelNummern
ThisWorkbook.Worksheets(tbNameNEU).Cells(LoL, 6).Value = TypeVal
Call TelKosten
CallLength = ThisWorkbook.Worksheets(tbNameNEU).Cells(LoL, 2).Value
ThisWorkbook.Worksheets(tbNameNEU).Cells(LoL, 7).Value = CallLength * TelCosts
TypeVal = ""
TelNummer = ""
Next LoL
ThisWorkbook.Worksheets(tbNameNEU).Select
LoLetzte3 = ActiveSheet.UsedRange.SpecialCells(xlCellTypeLastCell).Row
For LoL = 2 To LoLetzte3
ThisWorkbook.Worksheets(tbNameNEU).Select
tbProjektkosten = ThisWorkbook.Worksheets(tbNameNEU).Cells(LoL, 9).Value
ThisWorkbook.Worksheets(tbNameNEU).Range(Cells(LoL, 1), Cells(LoL, 8)).Select
Selection.Copy
ThisWorkbook.Worksheets(tbProjektkosten).Select
Cells(65000, 1).End(xlUp).Offset(1, 0).Select
ActiveSheet.Paste
Application.CutCopyMode = False
Next LoL
Application.DisplayAlerts = False
ActiveWorkbook.SaveAs Filename:= _
PathXls & "\" & "Dialerkosten_" & loMonat & "-" & loMonatXls & ".xlsx", FileFormat _
:=xlOpenXMLWorkbook, CreateBackup:=False
Sheets("septdat3.rpt").Select
ActiveWindow.SelectedSheets.Delete
Sheets("septdat3 (bearbeitet)").Select
ActiveWindow.SelectedSheets.Delete
Sheets("Info").Select
ActiveWindow.SelectedSheets.Delete
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Call ArrayBefuellen
MsgBox "Ich habe fertig!!"
End Sub