Makro Problem

Computer: Software & Programmierung Office Software
1

Hallo. Ich hab ein Problem mit einem Makro, und zwar soll dieses Makro Werte von einer Spalte in ein anderes Blatt kopieren, diese dann zählen und die doppelten löschen. Nur leider bekomm ich auf dem Ausgangeblatt nur Nullen wieder. Mit „normalen“ Zahlen funktioniert das Makro nur irgendwie nicht mit der Uhrzeit. Hab auch mal eine Excel Tabelle hochgeladen wie das aussehen sollte.

Hier das Makro

Dim Zeile As Long, C As Long, colC As New Collection
On Error Resume Next
With Worksheets(„Tabelle1“)
For Zeile = 8 To .Cells(Rows.Count, 1).End(xlUp).Row '1=Spalte A
colC.Add Item:=CStr(.Cells(Zeile, 1)), Key:=CStr(.Cells(Zeile, 1))
Next Zeile
End With
On Error GoTo 0
With Worksheets(„Tabelle2“)
.Range(„A:B“).ClearContents
.Range(„A1“).Value = „Uhrzeit“
.Range(„B1“).Value = „Anzahl“
For Zeile = 1 To colC.Count
.Cells(Zeile + 1, 1).Value = Val(colC(Zeile))
Next Zeile
.Range(„A2:A“ & Zeile - 1).Sort Key1:=.Range(„A2“), Order1:=xlAscending, Header:=xlNo, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
.Range(„B2:B“ & Zeile - 1).FormulaLocal = „=ZÄHLENWENN(Tabelle1!A:A;A2)“
.Range(„B2:B“ & Zeile - 1).Value = .Range(„B2:B“ & Zeile - 1).Value
End With

Hier der Link für die Exceltablle
http://rapidshare.com/files/280815047/Mappe.xls.html

2

Hallo mr.tobi,

ich habe leider die Datei einmal geschlossen und nun kann ich sie kein zweites Mal herunterladen. Ich habe es mal so versucht, mit dem an was ich mich noch erinnern konnte. Versuchs mal mit diesem Code:

Sub Test()
Dim wb As Workbook, ws As Worksheet, wsZ As Worksheet
Set wb = ActiveWorkbook: Set ws = wb.Sheets(1): Set wsZ = wb.Sheets(2)
Application.ScreenUpdating = False
For a = 1 To ws.Cells(65536, 1).End(xlUp).Row
wsZ.Cells(a, 1) = ws.Cells(a, 1)
Next a
wsZ.Range(wsZ.Cells(2, 1), wsZ.Cells(wsZ.Cells(65536, 1).End(xlUp).Row, 1)).Sort Key1:=wsZ.Cells(1, 1)
wsZ.Cells(2, 2).Formula = „=COUNTIF(R2C1:R“ & wsZ.Cells(65536, 1).End(xlUp).Row & „C1,RC[-1])“
wsZ.Cells(2, 3).Formula = „=IF(RC[-2]=R[1]C[-2],m,1)“
wsZ.Range(wsZ.Cells(2, 2), wsZ.Cells(2, 3)).Copy
With wsZ.Range(wsZ.Cells(2, 2), wsZ.Cells(wsZ.Cells(65536, 1).End(xlUp).Row, 3))
.PasteSpecial xlFormulas
.Value = .Value
.SpecialCells(xlCellTypeConstants, 16).EntireRow.Delete
End With
wsZ.Cells(2, 3).EntireColumn.Delete
wsZ.Range(„A:A“).NumberFormat = „hh:mm:ss“
wsZ.Range(„B:B“).NumberFormat = „General“
wsZ.Range(„A1“).Select
End Sub

3

Hallo. Ich hab ein Problem mit einem Makro, und zwar soll
dieses Makro Werte von einer Spalte in ein anderes Blatt
kopieren, diese dann zählen und die doppelten löschen. Nur
leider bekomm ich auf dem Ausgangeblatt nur Nullen wieder. Mit
„normalen“ Zahlen funktioniert das Makro nur irgendwie nicht
mit der Uhrzeit. Hab auch mal eine Excel Tabelle hochgeladen
wie das aussehen sollte.

Hallo Mr,

Sub Kopier()
Dim Formel As String, Zei1 As Long
Zei1 = Worksheets("Tabelle1").Cells(Rows.Count, 1).End(xlUp).Row
Formel = "=ZÄHLENWENN(Tabelle1!A:A;A2)"
With Worksheets("Tabelle2")
 .Range("A2:B500").ClearContents
 Worksheets("Tabelle1").Range("A2:A" & Zei1).AdvancedFilter Action:=xlFilterCopy, \_
 CopyToRange:=.Range("A2"), Unique:=True
 .Rows(2).Delete
 With .Range("B2:B" & .Cells(Rows.Count, 1).End(xlUp).Row)
 .FormulaLocal = Formel
 .Value = .Value
 End With
End With
End Sub

Gruß
Reinhard

4

danke schonmal.

wenn ich das jetzt für die Spalte H machen will, sieht das dann so aus?

Sub Kopier1()
Dim Formel As String, Zei1 As Long
Zei1 = Worksheets(„Tabelle1“).Cells(Rows.Count, 1).End(xlUp).Row
Formel = „=ZÄHLENWENN(Tabelle1!h:h;h2)“
With Worksheets(„Tabelle2“)
.Range(„A2:B500“).ClearContents
Worksheets(„Tabelle1“).Range(„h2:h“ & Zei1).AdvancedFilter Action:=xlFilterCopy, _
CopyToRange:=.Range(„A2“), Unique:=True
.Rows(2).Delete
With .Range(„B2:B“ & .Cells(Rows.Count, 1).End(xlUp).Row)
.FormulaLocal = Formel
.Value = .Value
End With
End With
End Sub

5

danke schonmal.

wenn ich das jetzt für die Spalte H machen will, sieht das
dann so aus?

Na noch nicht ganz…

Zei1 = Worksheets(„Tabelle1“).Cells(Rows.Count, 1 ).End(xlUp).Row

Hier musst du den Spaltenindex auf „8“ setzten, sonst wird nicht Spalte H gezählt.

Formel = „=ZÄHLENWENN(Tabelle1!h:h;h2)“

Die Formel zählt zwar die Werte aus der Spalte H in Tabellen1, vergleicht sie jedoch mit dem aktuellen Wert aus Tabelle2. Also

Formel = „=ZÄHLENWENN(Tabelle1!h:h; A2 )“

Der Rest ist ok.

6

Ok hat geklappt, besten Dank

7

Guten Morgen.
Ich hab wieder ein kleines Problem, und zwar wollte ich dass das Makro zusätzlich wie schon für die Spalte H das gleiche für die Spalten F und G macht, nur nicht auf Tabelle 2 sondern auf Tabelle 3 und 4. Hab mir gedacht einfach den Code für Spalte H kopieren, ein bisschen anpassen und fertig aber leider funktioniert es nicht so wie es soll. Alternativ könnte man die Anzahl von Spalte F und G auch in der Tabelle 2 in Spalte C und D platzieren, also neben der Anzahl von Spalte H, was eigentlich noch besser und schöner wäre.

link für die Excel Tabelle

http://rapidshare.com/files/281217423…

Sub Ganglinie()

'Obergrenze von Uhrzeit ausrechnen
Dim Zeile As Long
Sheets(„Tabelle1“).Select
Zeile = Range(„B“ & Rows.Count).End(xlUp).Row
Range(„H2:H“ & Zeile).FormulaR1C1 = „=CEILING(RC[-6],1/24)“
Range(„f2:f“ & Zeile).FormulaR1C1 = „=IF(RC[-1]8500,RC[1],“""")"

'in hh:mm umwandeln
Range(„H:H“).Select
Range(„G:G,F:F“).Select
Selection.NumberFormat = „h:mm;@“

'Formeln in Festwerte umwandeln
Dim Zelle As Range
On Error Resume Next
For Each Zelle In ActiveSheet.UsedRange
If Left(Zelle.Formula, 1) = „=“ Then _
Zelle.Formula = Zelle.Value
Next

'Werte von Tabelle 1 Spalte H nach Tabelle 2 kopieren,
'zählen und doppelte löschen
Dim Formel As String, Zei1 As Long
Zei1 = Worksheets(„Tabelle1“).Cells(Rows.Count, 8).End(xlUp).Row 'Spalte H = 8
Formel = „=ZÄHLENWENN(Tabelle1!H:H;A2)“
With Worksheets(„Tabelle2“)
.Range(„A2:B500“).ClearContents
.Range(„A1“).Value = „Uhrzeit“
.Range(„B1“).Value = „Anzahl“
Worksheets(„Tabelle1“).Range(„H2:H“ & Zei1).AdvancedFilter Action:=xlFilterCopy, _
CopyToRange:=.Range(„A2“), Unique:=True
.Rows(2).Delete
With .Range(„B2:B“ & .Cells(Rows.Count, 1).End(xlUp).Row)
.FormulaLocal = Formel
.Value = .Value
End With
End With

'Werte von Tabelle 1 Spalte f nach Tabelle 3 kopieren,
'zählen und doppelte löschen
Dim Formel2 As String, Zei2 As Long
Zei2 = Worksheets(„Tabelle1“).Cells(Rows.Count, 6).End(xlUp).Row 'Spalte f = 6
Formel2 = „=ZÄHLENWENN(Tabelle1!f:f;A2)“
With Worksheets(„Tabelle3“)
.Range(„A2:B500“).ClearContents
Worksheets(„Tabelle1“).Range(„f2:f“ & Zei2).AdvancedFilter Action:=xlFilterCopy, _
CopyToRange:=.Range(„A2“), Unique:=True
.Rows(2).Delete
With .Range(„B2:B“ & .Cells(Rows.Count, 1).End(xlUp).Row)
.FormulaLocal = Formel2
.Value = .Value
End With
End With

'Werte von Tabelle 1 Spalte g nach Tabelle 4 kopieren,
'zählen und doppelte löschen
Dim Formel3 As String, Zei3 As Long
Zei3 = Worksheets(„Tabelle1“).Cells(Rows.Count, 7).End(xlUp).Row 'Spalte g = 7
Formel3 = „=ZÄHLENWENN(Tabelle1!g:g;A2)“
With Worksheets(„Tabelle4“)
.Range(„A2:B500“).ClearContents
Worksheets(„Tabelle1“).Range(„g2:g“ & Zei3).AdvancedFilter Action:=xlFilterCopy, _
CopyToRange:=.Range(„A2“), Unique:=True
.Rows(2).Delete
With .Range(„B2:B“ & .Cells(Rows.Count, 1).End(xlUp).Row)
.FormulaLocal = Formel3
.Value = .Value
End With
End With

End Sub