AW: Was macht dieser Code?
13.01.2005 10:37:16
Ralf
Ok, das sieht schon viel besser aus.
Jetzt geht es an das Hauptmakro.
Das ganze soll ja folgendermassen sein:
Datenimport durch Makro "Import" von Shhet "Import"
Die Daten sind nur Telefonnummern quasi. Mal mit "0", mal ohne "0" an erster Stelle, alles mit "0" ist Outgoing, alles andere Incoming.
Danach wird unterschieden. Dann sollen die Daten nur in die entsprechenden Shhets eingepflegt werden und die Grafik übernimmt sie dann mit in die Auswertung.
Problem zur Zeit: Ab einer bestimmten Zeile wird nichts mehr unten angefügt, warum auch immer.
Der Code sieht im Hauptmakro so aus:
Sub Import_01()
' Import_01 Makro
' Datum eintragen
Sheets("Import").Select
Range("A1").Select
Selection.Copy
Range(Selection, Selection.End(xlDown)).Select
ActiveSheet.Paste
' Tabellen Export
Sheets("Import").Select
Selection.End(xlUp).Select
Range("A1:O1").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Sheets("Export").Select
Range("A2").Select
ActiveSheet.Paste
Datum1 = Cells(2, 1)
Jahr1 = Mid(Datum1, 7, 4)
Monat1 = Mid(Datum1, 4, 2)
Tag1 = Mid(Datum1, 1, 2)
TBName = "Export"
WBName = "\\Server\Pfad\" & Jahr1 & Monat1 & Tag1 & ".xls"
Worksheets(TBName).Copy
ActiveWorkbook.SaveAs WBName
ActiveWorkbook.Close
Application.CutCopyMode = False
Selection.ClearContents
' Daten nach links verschieben
Sheets("Import").Select
Selection.End(xlUp).Select
Range("J1:O1").Select
Range(Selection, Selection.End(xlDown)).Select
Application.CutCopyMode = False
Selection.Cut
Range("D1").Select
ActiveSheet.Paste
' Rufnummern mit "0..." kopieren
Sheets("Import").Select
Application.ScreenUpdating = False
For i = 1 To 150
Rows(i).Hidden = False
Next i
Application.ScreenUpdating = True
Application.ScreenUpdating = False
For i = 1 To 150
If Cells(i, 2).Value >= "0?" Then
Rows(i).Hidden = True
End If
Next i
Application.ScreenUpdating = True
Selection.End(xlUp).Select
Selection.End(xlUp).Select
Selection.End(xlUp).Select
Selection.CurrentRegion.Select
Selection.SpecialCells(xlCellTypeVisible).Select
Selection.Copy
Sheets("Outgoing").Select
Range("A1").Select
letztezeile = ActiveSheet.Cells(65536, 1).End(xlUp).Row
letztezeile = letztezeile + 1
Adresse = Cells2Range(letztezeile, 1)
Range(Adresse).Select
ActiveSheet.Paste
Selection.End(xlUp).Select
Range("A2").Select
' Rufnummern ohne "0..." kopieren
Sheets("Import").Select
Application.ScreenUpdating = False
For i = 1 To 150
Rows(i).Hidden = False
Next i
Application.ScreenUpdating = True
Application.ScreenUpdating = False
For i = 1 To 150
If Cells(i, 2).Value < "0?" Then
Rows(i).Hidden = True
End If
Next i
Application.ScreenUpdating = True
Selection.End(xlUp).Select
Selection.End(xlUp).Select
Selection.End(xlUp).Select
Selection.CurrentRegion.Select
Selection.SpecialCells(xlCellTypeVisible).Select
Selection.Copy
Sheets("Incoming").Select
Range("A1").Select
letztezeile = ActiveSheet.Cells(65536, 1).End(xlUp).Row
letztezeile = letztezeile + 1
Adresse = Cells2Range(letztezeile, 1)
Range(Adresse).Select
ActiveSheet.Paste
Selection.End(xlUp).Select
Range("A2").Select
' Import-Tabelle löschen
Sheets("Import").Select
Application.ScreenUpdating = False
For i = 1 To 150
Rows(i).Hiddem = False
Next i
Application.ScreenUpdating = True
Selection.End(xlUp).Select
Selection.End(xlUp).Select
Selection.End(xlUp).Select
Selection.CurrentRegion.Select
Application.CutCopyMode = False
Selection.ClearContents
Selection.End(xlUp).Select
Columns("B:B").Select
Selection.NumberFormat = "@"
Range("A1").Select
Sheets("Outgoing").Select
Selection.End(xlUp).Select
Range("A1").Select
End Sub
Function Cells2Range(Zeile, Spalte)
Spalte = Columns(Spalte).Address(False, False)
Spalte = Left(Spalte, InStr(Spalte, ":") - 1)
Cells2Range = Spalte & Zeile
End Function
Da blicke ich nicht durch ... leider.
Es gibt noch ein kleines Makro was eine Toolbar öffnet mit 2 Buttons, eher irrelevant denke ich, oder?
Kann man diesen Code besser machen? Oder sind da von vornherein Fehler drin?
Vielen vielen herzlichen Dank!
Ralf