AW: doppelte werte in zeile -> pro wert in a eine zeil
04.10.2017 20:11:20
Stefan
Ich habe es so gelöst:
Sub zusammenfassen()
Dim such1 As String
Dim such2 As String
Dim GHS As String
Dim i As Integer
Dim y As Integer
i = 1
y = 1
Sheets("Prod Rez").Activate
'schleife zum durchlaufen der arbeitsblattes
For i = 1 To ActiveSheet.UsedRange.Rows.Count
such1 = Cells(i + 1, 1).Value
such2 = Cells(y + 2, 1).Value
GHS = Cells(i + 1, 2)
'abfangen GHS in erster zeile
Select Case Right(GHS, 1)
Case 2
Cells(i + 1, 2) = GHS
Case 5
Cells(i + 1, 3) = GHS
Case 6
Cells(i + 1, 4) = GHS
Case 7
Cells(i + 1, 5) = GHS
Case 8
Cells(i + 1, 6) = GHS
Case 9
Cells(i + 1, 7) = GHS
End Select
'nun alle dupliakte suchen
For y = i + 1 To ActiveSheet.UsedRange.Rows.Count
such2 = Cells(y + 1, 1).Value
If such1 = such2 Then
GHS = Cells(y + 1, 2)
'werte setzen
Select Case Right(GHS, 1)
Case 2
Cells(i + 1, 2) = GHS
Case 5
Cells(i + 1, 3) = GHS
Case 6
Cells(i + 1, 4) = GHS
Case 7
Cells(i + 1, 5) = GHS
Case 8
Cells(i + 1, 6) = GHS
Case 9
Cells(i + 1, 7) = GHS
End Select
' zeile löschen
Cells(y + 1, 1).EntireRow.Delete
y = y - 1
End If
Next y
Next i
End Sub
Sub zusa_labor()
Dim such1 As String
Dim such2 As String
Dim GHS As String
Dim i As Integer
Dim y As Integer
i = 1
y = 1
Sheets("Labor Rez").Activate
'schleife zum durchlaufen der arbeitsblattes
For i = 1 To ActiveSheet.UsedRange.Rows.Count
such1 = Cells(i + 1, 1).Value
such2 = Cells(y + 2, 1).Value
GHS = Cells(i + 1, 2)
'abfangen GHS in erster zeile
Select Case Right(GHS, 1)
Case 2
Cells(i + 1, 2) = GHS
Case 5
Cells(i + 1, 3) = GHS
Case 6
Cells(i + 1, 4) = GHS
Case 7
Cells(i + 1, 5) = GHS
Case 8
Cells(i + 1, 6) = GHS
Case 9
Cells(i + 1, 3) = GHS
End Select
'nun alle dupliakte suchen
For y = i + 1 To ActiveSheet.UsedRange.Rows.Count
such2 = Cells(y + 1, 1).Value
If such1 = such2 Then
GHS = Cells(y + 1, 2)
'werte setzen
Select Case Right(GHS, 1)
Case 2
Cells(i + 1, 2) = GHS
Case 5
Cells(i + 1, 3) = GHS
Case 6
Cells(i + 1, 4) = GHS
Case 7
Cells(i + 1, 5) = GHS
Case 8
Cells(i + 1, 6) = GHS
Case 9
Cells(i + 1, 3) = GHS
End Select
' zeile löschen
Cells(y + 1, 1).EntireRow.Delete
y = y - 1
End If
Next y
Next i
End Sub