Adetleri dağıtılmış ürünlerin yanına fiyat getirilmesi

[izcik]

Kıymetli uzmanlarım,

Çok değerli Mehmet Arslan'ın yardımıyla,

http://www.excel.web.tr/showpost.php?p=416623&postcount=13

13. mesajında edindiğim dosyayı severek kullanıyorum.



Makronun sonucunu aynı sayfada çıkmasını istediğimden (amacım; sonucun aynı sayfada çıkması idi) , kodların içerisinde (bildiğimden değil sadece mantığımı çalıştırarak) şu değişiklikleri yaptım ; ve neticede (deneme yanılmayla) oldu. Biraz Ömer uzmanımın eski kodlarını da içine kattım.


İhtiyacım olan şey şu:

C sütunundaki fiyatların da

G sütununda ürünlerin karşılığına doğru olarak gelmesi.

Teşekkür ederim .

Saygılar

 

[meslan]

Sn izcik merhaba

Sub Dağıt()
[E1] = [A1]
[F1] = [B1]
[G1] = [C1]
Sheets("KOLİ ADETLERİ DAĞITMA").[E2:G65536].Clear
For i = 2 To Sheets("KOLİ ADETLERİ DAĞITMA").[a65536].End(3).Row
Seç = ""
    For X = 1 To Len(Sheets("KOLİ ADETLERİ DAĞITMA").Cells(i, 2)) + 1
        If IsNumeric(Mid(Sheets("KOLİ ADETLERİ DAĞITMA").Cells(i, 2), X, 1)) Then Seç = Seç & Mid(Sheets("KOLİ ADETLERİ DAĞITMA").Cells(i, 2), X, 1)
        If Not IsNumeric(Mid(Sheets("KOLİ ADETLERİ DAĞITMA").Cells(i, 2), X, 1)) Or Mid(Sheets("KOLİ ADETLERİ DAĞITMA").Cells(i, 2), X, 1) = Empty Then
        Sheets("KOLİ ADETLERİ DAĞITMA").[E65536].End(3)(2, 1) = Sheets("KOLİ ADETLERİ DAĞITMA").Cells(i, 1)
        Set Fyt = [A:A].Find(Sheets("KOLİ ADETLERİ DAĞITMA").[E65536].End(3)(1, 1), lookat:=xlWhole)
        If Not Fyt Is Nothing Then Sheets("KOLİ ADETLERİ DAĞITMA").[E65536].End(3)(1, 3) = Cells(Fyt.Row, 3).Value
        Sheets("KOLİ ADETLERİ DAĞITMA").[E65536].End(3)(1, 2) = Seç
        Seç = ""
        End If
    Next
Next
Sheets("KOLİ ADETLERİ DAĞITMA").Select
End Sub

Kolay gelsin.

 

[Ömer]

Merhaba,

Sub Dağıt()
Application.ScreenUpdating = False
Set S1 = Sheets("KOLİ ADETLERİ DAĞITMA")
S1.Select
[E1] = [A1]
[F1] = [B1]
[G1] = [C1]
[E2:[COLOR=red]G[/COLOR]65536].ClearContents
For i = 2 To [A65536].End(3).Row
Seç = ""
    For x = 1 To Len(Cells(i, 2)) + 1
        If IsNumeric(Mid(Cells(i, 2), x, 1)) Then Seç = Seç & Mid(Cells(i, 2), x, 1)
        If Not IsNumeric(Mid(Cells(i, 2), x, 1)) Or Mid(Cells(i, 2), x, 1) = Empty Then
          [E65536].End(3)(2, 1) = Cells(i, 1)
          [COLOR=red][E65536].End(3)(1, 3) = Cells(i, 3)[/COLOR]
          [E65536].End(3)(1, 2) = Seç
          Seç = ""
        End If
    Next
Next
Application.ScreenUpdating = True
End Sub

Eklenen satırı işaretledim. Diğer düzeltmeler sayfa ile ilgili kısaltmalardır.

.

 

[izcik]

Duygulanmamak elde değil. Çok teşekkürler arkadaşlarım.