DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
Altın Üyelik Hakkında Bilgi
Dosyanız ektedir.Teşekkür ederim ama makro istiyorum ben. Sayın Evren hocamızın yeni yaptığı bir makro var o şekilde makroyla yani
Option Base 1
Sub benzersiz_topla_aktar_59()
Dim sh As Worksheet, liste(), myarr(), a As Long, n As Long
Dim sat As Long, z As Object, sut As Byte, i As Long
Sheets("SONUC").Select
Application.Calculation = xlCalculationManual
If ActiveSheet.AutoFilterMode = True Then ActiveSheet.AutoFilterMode = False
Range("A6:I65536,I6:I65536").ClearContents
Set z = CreateObject("Scripting.Dictionary")
ReDim myarr(1 To 9, 1 To 65536)
For Each sh In Worksheets
If sh.Name <> ActiveSheet.Name Then
sat = sh.Cells(65536, "C").End(xlUp).Row
If sat > 2 Then
liste = sh.Range("B3:D" & sat).Value
For i = 1 To UBound(liste, 1)
If Not z.exists(liste(i, 2)) Then
n = n + 1
z.Add liste(i, 2), n
myarr(1, n) = n
myarr(2, n) = liste(i, 1)
myarr(3, n) = liste(i, 2)
myarr(4, n) = liste(i, 3)
End If
If sh.Name = CStr(Range("F5").Value) Then sut = 6
If sh.Name = CStr(Range("G5").Value) Then sut = 7
If sh.Name = CStr(Range("H5").Value) Then sut = 8
If sh.Name = "SAATE GÖRE" Then sut = 9
myarr(sut, z.Item(liste(i, 2))) = myarr(sut, z.Item(liste(i, 2))) + 1
Next i
Erase liste
End If
End If
Next sh
If n > 0 Then
Application.ScreenUpdating = False
Range("A6").Resize(n, 9) = Application.Transpose(myarr)
sat = Cells(65536, "C").End(xlUp).Row
Range("B6:I" & sat).Sort Range("C6")
Application.ScreenUpdating = True
MsgBox "Aktarım tamamlandı." & vbLf & _
"evrengizlenqhotmail.com", vbOKOnly + vbInformation, "E V R E N"
End If
Erase myarr: Set z = Nothing
Application.Calculation = xlCalculationAutomatic
End Sub
Rica ederim.Sayın Evren Gizlen;
Çok teşekkür ediyorum elinize bilginize sağlık.
Rica ederim.Teşekkür ederim. İyi çalışmalar.
Bence benim yazdığım kodlarda hata yok.Kodlar gayet güzel çalışıyor.Sayın Evren Gizlen hocam dosyayı inceledikçe aksaklıklar olduğunu farkettim. Bazı malzemeleri hatalı aktarıyor. Ben sadece birazını inceleyebildim. Asıl bilgilerin hepsini dosyaya ekleyip te aktarma yapacak olursam hepsini inceleme şansım da hiç olmayacak. Hatalı bilgi aktarmasını önlemek gerek. Tekrar bakabilirmisiniz acaba. Dosyayı ekledim. Hatalı olan bilgileri işaretledim. Bunlar sadece ilk görebildiğim aksaklık. Belki başkada çıkabilir hepsini inceleme imkanı zor çünkü. Sizi yoruyorum ama kusura bakmayın lütfen. Bir de sonuç sayfasının c sütununa göre küçükten büyüğe sıralama imkanı olursa daha da güzel olacak. Ayrıca bu kodlar çok hızlı çalışıyor. Saygılarmla.
Peki sorarım size siz bunu söylemezseniz nasıl anlayacağız bunu.Yani burada sonucun doğru çıkması bizim mahretimize göre değil tamamen sizin konuyu doğru açıklmanıza bağlıdır.Şimdi düzelticem.Şimdi anladım. Siz parça adı olan B sütununa göre yapmışsınız. Burda önemli olan yani bizim kullanımımızda parça no sudur. Kısacası C sütunu baz alınarak birleştirme yapılacak parça adını fazla önemi yok. Önemli olan parça no. Umarım yeteri kadar açıklayabilmişimdir. Teşekkür ederim.
Dosyayı güncelledim.4 numaralı mesajdan indirebilirsiniz.Şimdi anladım. Siz parça adı olan B sütununa göre yapmışsınız. Burda önemli olan yani bizim kullanımımızda parça no sudur. Kısacası C sütunu baz alınarak birleştirme yapılacak parça adını fazla önemi yok. Önemli olan parça no. Umarım yeteri kadar açıklayabilmişimdir. Teşekkür ederim.
İstediğiniz düzenlemeyi yaptım.Şu an inceleyebildiğim kadarıyla sorun görünmüyor. Birde sıralı olmasını istemiştim ama siz onu atladınız sanırım. Sonuç sayfasının C sütunu küçükten büyüğe göre sıralamasını. Fazla uğraştıracaksa bu şekildede kullanırım. Çok emeğiniz geçti hakkınızı helal ediniz. Teşekkür ederim.
Çok teşekkür ederim. İyi çalışmalar.