- Katılım
- 28 Eylül 2007
- Mesajlar
- 4,042
- Excel Vers. ve Dili
- 2013 Türkçe
Sub Aktar()
Application.ScreenUpdating = False
Range("E:GG") = ""
Sheets("Gsm").Range("C2:CC1000").ClearContents
son = Cells(Rows.Count, "C").End(3).Row
Range("E2:E" & son) = "=LEFT(B2,3)"
Range("E2:E" & son) = Range("E2:E" & son).Value
Range("F2:F" & son) = "=IF(COUNTIF(E$2:E2,E2)=1,E2,"""")"
Range("F2:F" & son) = Range("F2:F" & son).Value
Range("F2:F" & son).SpecialCells(xlCellTypeBlanks).Delete Shift:=xlUp
For i = 2 To son
kac = WorksheetFunction.Match(Cells(i, 5), Range("F1:F10000"), 0)
süt = WorksheetFunction.CountA(Range("G" & kac & ":GG" & kac)) + 7
adet = WorksheetFunction.CountIf(Range("G" & kac & ":GG" & kac), Cells(i, 4))
If adet > 0 Then GoTo 50
Cells(kac, süt) = Cells(i, 4).Value
50
Next
Range("G:GG").Replace What:=";", Replacement:=""
son = Sheets("Gsm").Cells(Rows.Count, "A").End(3).Row
For i = 2 To son
If WorksheetFunction.CountIf(Range("B2:B10000"), Sheets("Gsm").Cells(i, 1)) = 0 Then GoTo 100
bul = WorksheetFunction.VLookup(Sheets("Gsm").Cells(i, 1), Range("B2:E10000"), 4, 0)
kac = WorksheetFunction.Match(bul, Range("F1:F10000"), 0)
Sheets("Gsm").Range("C" & i & ":CC" & i) = Range("G" & kac & ":GG" & kac).Value
100
Next
Range("E:GG") = ""
Sheets("Gsm").Select
End Sub
Dosyayı yeterince deneme şansım olmadı. Siz denemeler yapınız, kontrol ediniz. Yanlış bir durum var mı diye
Son düzenleme:
