• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

Her birimi kendi içinde toplatmak

S

stier_22

Altın Üye
Katılım
15 Eylül 2009
Mesajlar
147
Excel Vers. ve Dili
excel 2016
Arkadaşlar ekte yer alan listede mal cinslerine ait adetler parça parça yazılmış.

Bunları tek seferde 100 Adet 200 Metre 60 KG olarak yapabilir miyiz? ama her bir hücre kendi içinde bu şekilde toplanacak

10 AD, 5000 AD, 10 AD, 10000 AD, 20 AD, 60000 AD, 30 KG 314 MT, 300 MT, 200 MT, 600 MT, 700 MT, 1200 MT, 800 MT, 400 MT, 500 M
Bu girdilerin bana her biri kendi içinde toplam birim bazında gelmesini istiyorum :???:

http://www.dosya.tc/server11/lpnhwd/MAL_CINSI.xlsx.html
 
Bu kodu bir deneyiniz.

Kod: 
Sub aktar()
Application.ScreenUpdating = False
Application.DisplayAlerts = False

sat = 5
s = 3
Columns("B:F").ClearContents

For r = 5 To Cells(Rows.Count, "a").End(3).Row

AlinacakVeri = "."
adres = Cells(r, "a").Value
a = InStr(Trim(adres), AlinacakVeri)

t = 0
k = 1
If a > 0 Then
For j = a To Len(adres)
bulunan1 = InStr(j, adres, AlinacakVeri, vbTextCompare)
If bulunan1 > 0 Then
yer = WorksheetFunction.Trim(Mid(adres, k, bulunan1 - k))


If IsNumeric(Mid(yer, 1, 2)) = True Then
Cells(sat, "F").Value = WorksheetFunction.Trim(Mid(yer, 3, Len(yer)))
Cells(sat, "E").Value = WorksheetFunction.Trim(Mid(yer, 1, 2))
ElseIf IsNumeric(Mid(yer, 1, 1)) = True Then
Cells(sat, "F").Value = WorksheetFunction.Trim(Mid(yer, 2, Len(yer)))
Cells(sat, "E").Value = WorksheetFunction.Trim(Mid(yer, 1, 1))

Else
Cells(sat, "F").Value = yer
End If

sat = sat + 1
j = bulunan1 + 1
k = bulunan1 + 1
t = 1
Else

yer2 = WorksheetFunction.Trim(Mid(adres, k, Len(adres)))

If IsNumeric(Mid(yer2, 1, 2)) = True Then
Cells(sat, "F").Value = WorksheetFunction.Trim(Mid(yer2, 3, Len(yer2)))
Cells(sat, "E").Value = WorksheetFunction.Trim(Mid(yer2, 1, 2))
ElseIf IsNumeric(Mid(yer2, 1, 1)) = True Then
Cells(sat, "F").Value = WorksheetFunction.Trim(Mid(yer2, 2, Len(yer2)))
Cells(sat, "E").Value = WorksheetFunction.Trim(Mid(yer2, 1, 1))


Else
Cells(sat, "F").Value = yer2
End If

sat = sat + 1
Exit For
End If
Next j
End If

If t = 0 Then


If IsNumeric(Mid(adres, 1, 2)) = True Then
Cells(sat, "F").Value = WorksheetFunction.Trim(Mid(adres, 3, Len(adres)))
Cells(sat, "E").Value = WorksheetFunction.Trim(Mid(adres, 1, 2))
ElseIf IsNumeric(Mid(adres, 1, 1)) = True Then
Cells(sat, "F").Value = WorksheetFunction.Trim(Mid(adres, 2, Len(adres)))
Cells(sat, "E").Value = WorksheetFunction.Trim(Mid(adres, 1, 1))


Else
Cells(sat, "F").Value = adres
End If


sat = sat + 1
End If

Next r

Set j = CreateObject("Scripting.Dictionary")
For Each X In Range("F5:F" & Cells(Rows.Count, "F").End(3).Row)
If UCase(X.Value) <> "" Then
If Not j.exists(UCase(X.Value)) Then
j.Add UCase(X.Value), Nothing
s = s + 1
Cells(s + 1, "b").Value = UCase(X.Value)
Cells(s + 1, "c").Value = WorksheetFunction.CountIf(Range("F:F"), Cells(s + 1, "b").Value)
Cells(s + 1, "d").Value = WorksheetFunction.SumIf(Range("F:F"), Cells(s + 1, "b").Value, Range("E:E"))
End If

End If
Next X




Application.ScreenUpdating = True
Application.DisplayAlerts = True

MsgBox "işlem tamam"

End Sub
 
Bu kod da farklı

Kod: 
Sub aktar2()
Application.ScreenUpdating = False
Application.DisplayAlerts = False


sat1 = 5
sat2 = 5
Columns("B:G").ClearContents

For r = 5 To Cells(Rows.Count, "a").End(3).Row

AlinacakVeri = ","

adres = Cells(r, "a").Value & AlinacakVeri

deg1 = Split(adres, AlinacakVeri)
If UBound(deg1) > 0 Then
For m = 0 To UBound(deg1) - 1

deg2 = Split(Trim(deg1(m)), " ")
If UBound(deg2) > 0 Then

Cells(sat2, "e").Value = deg2(0)
Cells(sat2, "f").Value = deg2(1)
End If
Cells(sat2, "g").Value = Trim(deg1(m))
sat2 = sat2 + 1
Next m
Else
End If
Next r

Set j = CreateObject("Scripting.Dictionary")
For Each X In Range("F5:F" & Cells(Rows.Count, "F").End(3).Row)
If UCase(X.Value) <> "" Then
If Not j.exists(UCase(X.Value)) Then
j.Add UCase(X.Value), Nothing

Cells(sat1, "b").Value = UCase(X.Value)
Cells(sat1, "c").Value = WorksheetFunction.CountIf(Range("F:F"), Cells(sat1, "b").Value)
Cells(sat1, "d").Value = WorksheetFunction.SumIf(Range("F:F"), Cells(sat1, "b").Value, Range("E:E"))
sat1 = sat1 + 1
End If

End If
Next X

Application.ScreenUpdating = True
Application.DisplayAlerts = True

MsgBox "işlem tamam"

End Sub
 
Yardımcı sutünsüz kod

Kod: 
Sub aktar3()
Application.ScreenUpdating = False
Application.DisplayAlerts = False

ReDim ara1(65000): ReDim ara2(65000): ReDim ara3(65000)
sat1 = 5
sat2 = 0
Columns("B:D").ClearContents
For r = 5 To Cells(Rows.Count, "a").End(3).Row
AlinacakVeri = ","
adres = Cells(r, "a").Value & AlinacakVeri
deg1 = Split(adres, AlinacakVeri)
If UBound(deg1) > 0 Then
For m = 0 To UBound(deg1) - 1
deg2 = Split(Trim(deg1(m)), " ")
If UBound(deg2) > 0 Then
sat2 = sat2 + 1

ara1(sat2) = deg2(0)
ara2(sat2) = deg2(1)


'Cells(sat2 + 4, "e").Value = deg2(0)
'Cells(sat2 + 4, "f").Value = deg2(1)
'Cells(sat2 + 4, "g").Value = Trim(deg1(m))

End If


Next m
Else
End If
Next r

sat3 = 5

For r = 1 To sat2
aranan1 = ara1(r)
aranan2 = ara2(r)

If Val(ara3(r)) = 1 Then GoTo atla

say1 = 0
say2 = 0

For i = r To sat2
If Val(ara3(i)) = 0 Then
bulunan1 = Replace(ara1(i), ".", ",")
bulunan2 = ara2(i)
If aranan2 = bulunan2 Then
say1 = say1 + CDbl(bulunan1)
'say1 = say1 + (Round(bulunan1, 2))
say2 = say2 + 1
ara3(i) = 1
End If
End If

Next i



Cells(sat3, "b").Value = aranan2
Cells(sat3, "c").Value = say2
Cells(sat3, "d").Value = say1
sat3 = sat3 + 1
atla:

Next r

Application.ScreenUpdating = True
Application.DisplayAlerts = True

MsgBox "işlem tamam"

End Sub
 
halit3' Alıntı:
Yardımcı sutünsüz kod

Kod: 
Sub aktar3()
Application.ScreenUpdating = False
Application.DisplayAlerts = False

ReDim ara1(65000): ReDim ara2(65000): ReDim ara3(65000)
sat1 = 5
sat2 = 0
Columns("B:D").ClearContents
For r = 5 To Cells(Rows.Count, "a").End(3).Row
AlinacakVeri = ","
adres = Cells(r, "a").Value & AlinacakVeri
deg1 = Split(adres, AlinacakVeri)
If UBound(deg1) > 0 Then
For m = 0 To UBound(deg1) - 1
deg2 = Split(Trim(deg1(m)), " ")
If UBound(deg2) > 0 Then
sat2 = sat2 + 1

ara1(sat2) = deg2(0)
ara2(sat2) = deg2(1)


'Cells(sat2 + 4, "e").Value = deg2(0)
'Cells(sat2 + 4, "f").Value = deg2(1)
'Cells(sat2 + 4, "g").Value = Trim(deg1(m))

End If


Next m
Else
End If
Next r

sat3 = 5

For r = 1 To sat2
aranan1 = ara1(r)
aranan2 = ara2(r)

If Val(ara3(r)) = 1 Then GoTo atla

say1 = 0
say2 = 0

For i = r To sat2
If Val(ara3(i)) = 0 Then
bulunan1 = Replace(ara1(i), ".", ",")
bulunan2 = ara2(i)
If aranan2 = bulunan2 Then
say1 = say1 + CDbl(bulunan1)
'say1 = say1 + (Round(bulunan1, 2))
say2 = say2 + 1
ara3(i) = 1
End If
End If

Next i



Cells(sat3, "b").Value = aranan2
Cells(sat3, "c").Value = say2
Cells(sat3, "d").Value = say1
sat3 = sat3 + 1
atla:

Next r

Application.ScreenUpdating = True
Application.DisplayAlerts = True

MsgBox "işlem tamam"

End Sub
Genişletmek için tıkla ...


Öncelikle yardımlarınız ve zahmetleriniz içinTeşekkür ederim fakat ben hiç makro kullanmadım deneme yanılma yoluyla makro oluşturmayı youtube dan bulup sizin yazdığınız makroyu kaydettim fakat 3 ayrı kod gönderdiğiniz için mi bilmem tam olmadı önce tek tek kopyaladım sonra alt alta. evet bazı toplamlar geliyor fakat yine tam istediğim gibi değil.

Ben kısaca bir hücrede (600 mt 300 kg 100 mt 200 kg 10 ad 20 ad) yazan verileri yine karşısındaki hücreye miktarsal bazda toplamlarını alarak 700 mt 500 kg 30 ad olarak bana vermesini istiyorum.
 
olması gerekeni örnek dosyaya ekleyerek buraya ekleyin bakalım
 
kOD

Kod: 
Sub aktar5()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Columns("C:BA").ClearContents
ReDim ara1(65000): ReDim ara2(65000): ReDim ara3(65000)

sat2 = 0

For r = 5 To Cells(Rows.Count, "a").End(3).Row
sayy1 = 0
AlinacakVeri = ","
adres = Cells(r, "a").Value & AlinacakVeri
deg1 = Split(adres, AlinacakVeri)
If UBound(deg1) > 0 Then
For m = 0 To UBound(deg1) - 1
deg2 = Split(Trim(deg1(m)), " ")
If UBound(deg2) > 0 Then

sayy1 = sayy1 + 1
ara1(sayy1) = deg2(0)
ara2(sayy1) = deg2(1)
ara3(sayy1) = 0
End If
Next m
End If

sut = 3

For j = 1 To sayy1
aranan1 = ara1(j)
aranan2 = ara2(j)
If Val(ara3(j)) = 1 Then GoTo atla2
say1 = 0
say2 = 0

For i = j To sayy1
If Val(ara3(i)) = 0 Then
bulunan1 = Replace(ara1(i), ".", ",")
bulunan2 = ara2(i)
If aranan2 = bulunan2 Then
say1 = say1 + CDbl(bulunan1)
say2 = say2 + 1
ara3(i) = 1
End If
End If

Next i

Cells(r, sut).Value = aranan2
Cells(r, sut + 1).Value = say1
sut = sut + 2
atla2:

Next j
Next r



Application.ScreenUpdating = True
Application.DisplayAlerts = True

MsgBox "işlem tamam"

End Sub
 
Herhalde istediğiniz bu olsa gerek

Kod: 
Sub aktar7()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Columns("b:B").ClearContents
ReDim ara1(100): ReDim ara2(100): ReDim ara3(100)

sat2 = 0

For r = 5 To Cells(Rows.Count, "a").End(3).Row
sayy1 = 0
AlinacakVeri = ","
adres = Cells(r, "a").Value & AlinacakVeri
deg1 = Split(adres, AlinacakVeri)
If UBound(deg1) > 0 Then
For m = 0 To UBound(deg1) - 1
deg2 = Split(Trim(deg1(m)), " ")
If UBound(deg2) > 0 Then
sayy1 = sayy1 + 1
ara1(sayy1) = deg2(0)
ara2(sayy1) = deg2(1)
ara3(sayy1) = 0
End If
Next m
End If

veri1 = ""

For j = 1 To sayy1
aranan1 = ara1(j)
aranan2 = ara2(j)
If Val(ara3(j)) = 1 Then GoTo atla2
say1 = 0

For i = j To sayy1
If Val(ara3(i)) = 0 Then
bulunan1 = Replace(ara1(i), ".", ",")
bulunan2 = ara2(i)
If aranan2 = bulunan2 Then
say1 = say1 + CDbl(bulunan1)
ara3(i) = 1
End If
End If

Next i

veri1 = veri1 & say1 & " " & aranan2 & ", "
atla2:
Next j
Cells(r, 2).Value = Mid(veri1, 1, Len(veri1) - 2)
Next r

Application.ScreenUpdating = True
Application.DisplayAlerts = True

MsgBox "işlem tamam"

End Sub
 
halit3' Alıntı:
Herhalde istediğiniz bu olsa gerek

Kod: 
Sub aktar7()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Columns("b:B").ClearContents
ReDim ara1(100): ReDim ara2(100): ReDim ara3(100)

sat2 = 0

For r = 5 To Cells(Rows.Count, "a").End(3).Row
sayy1 = 0
AlinacakVeri = ","
adres = Cells(r, "a").Value & AlinacakVeri
deg1 = Split(adres, AlinacakVeri)
If UBound(deg1) > 0 Then
For m = 0 To UBound(deg1) - 1
deg2 = Split(Trim(deg1(m)), " ")
If UBound(deg2) > 0 Then
sayy1 = sayy1 + 1
ara1(sayy1) = deg2(0)
ara2(sayy1) = deg2(1)
ara3(sayy1) = 0
End If
Next m
End If

veri1 = ""

For j = 1 To sayy1
aranan1 = ara1(j)
aranan2 = ara2(j)
If Val(ara3(j)) = 1 Then GoTo atla2
say1 = 0

For i = j To sayy1
If Val(ara3(i)) = 0 Then
bulunan1 = Replace(ara1(i), ".", ",")
bulunan2 = ara2(i)
If aranan2 = bulunan2 Then
say1 = say1 + CDbl(bulunan1)
ara3(i) = 1
End If
End If

Next i

veri1 = veri1 & say1 & " " & aranan2 & ", "
atla2:
Next j
Cells(r, 2).Value = Mid(veri1, 1, Len(veri1) - 2)
Next r

Application.ScreenUpdating = True
Application.DisplayAlerts = True

MsgBox "işlem tamam"

End Sub
Genişletmek için tıkla ...


Merhaba Halit Bey,

Kesinlikle budur çok teşekkür ederim ilginize harikasınız :dua2::dua2:
 
Kod: 
720 AD, 16 AD, 20 AD, 20 AD,50 m2,13m2, 100kg,15kg
8.5 AD, 38.4 AD, 70.25 M2, 5.19 M2, 9 MT
600 MT, 300 MT, 300 MT, 320 MT, 1000 MT, 940 MT, 300 MT, 1060 MT, 528 MT, 10200 ad, 5000 ad, 2.05kg, 5,35kg,100kg
5050 MT, 5000 MT, 530 MT, 510 MT, 5060 MT, 515 MT, 2000 MT, 5100 MT, 5

Örnek dosyanızdaki veriler yukarıdaki gibi ise bu kod daha kullanışlı

Kod: 
Sub aktar9()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Columns("B:B").ClearContents
ReDim ara1(100): ReDim ara2(100): ReDim ara3(100)

sat2 = 0

For r = 5 To Cells(Rows.Count, "a").End(3).Row
sayy1 = 0
AlinacakVeri = ","

adres = Cells(r, "a").Value
aranan = ","
bulunan = "."
aranan2 = "kg"
aranan3 = "m2"

For s = 0 To 9
adres = Replace(adres, s & aranan2, s & " " & aranan2)
adres = Replace(adres, s & aranan3, s & " " & aranan3)
adres = Replace(adres, s & ",", s & ".")

Next s

adres = Replace(adres, "  " & aranan2, " " & aranan2)
adres = Replace(adres, "  " & aranan3, " " & aranan3)
adres = Replace(adres, LCase(aranan3) & ".", LCase(aranan3) & ",")
adres = Replace(adres, UCase(aranan3) & ".", UCase(aranan3) & ",")
adres = Trim(adres) & AlinacakVeri

deg1 = Split(adres, AlinacakVeri)
If UBound(deg1) > 0 Then
For m = 0 To UBound(deg1) - 1
deg2 = Split(Trim(deg1(m)), " ")
If UBound(deg2) > 0 Then
sayy1 = sayy1 + 1
ara1(sayy1) = deg2(0)
ara2(sayy1) = deg2(1)
ara3(sayy1) = 0
End If
Next m
End If

veri1 = ""

For j = 1 To sayy1
aranan1 = ara1(j)
aranan2 = ara2(j)
If Val(ara3(j)) = 1 Then GoTo atla2
say1 = 0

For i = j To sayy1
If Val(ara3(i)) = 0 Then
bulunan1 = Replace(ara1(i), ".", ",")
bulunan2 = ara2(i)
If aranan2 = bulunan2 Then
say1 = say1 + CDbl(bulunan1)
ara3(i) = 1
End If
End If

Next i

veri1 = veri1 & say1 & " " & aranan2 & ", "
atla2:
Next j
Cells(r, 2).Value = Mid(veri1, 1, Len(veri1) - 2)
Next r

Application.ScreenUpdating = True
Application.DisplayAlerts = True

MsgBox "işlem tamam"

End Sub
 
halit3' Alıntı:
Kod: 
720 AD, 16 AD, 20 AD, 20 AD,50 m2,13m2, 100kg,15kg
8.5 AD, 38.4 AD, 70.25 M2, 5.19 M2, 9 MT
600 MT, 300 MT, 300 MT, 320 MT, 1000 MT, 940 MT, 300 MT, 1060 MT, 528 MT, 10200 ad, 5000 ad, 2.05kg, 5,35kg,100kg
5050 MT, 5000 MT, 530 MT, 510 MT, 5060 MT, 515 MT, 2000 MT, 5100 MT, 5

Örnek dosyanızdaki veriler yukarıdaki gibi ise bu kod daha kullanışlı

Kod: 
Sub aktar9()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Columns("B:B").ClearContents
ReDim ara1(100): ReDim ara2(100): ReDim ara3(100)

sat2 = 0

For r = 5 To Cells(Rows.Count, "a").End(3).Row
sayy1 = 0
AlinacakVeri = ","

adres = Cells(r, "a").Value
aranan = ","
bulunan = "."
aranan2 = "kg"
aranan3 = "m2"

For s = 0 To 9
adres = Replace(adres, s & aranan2, s & " " & aranan2)
adres = Replace(adres, s & aranan3, s & " " & aranan3)
adres = Replace(adres, s & ",", s & ".")

Next s

adres = Replace(adres, "  " & aranan2, " " & aranan2)
adres = Replace(adres, "  " & aranan3, " " & aranan3)
adres = Replace(adres, LCase(aranan3) & ".", LCase(aranan3) & ",")
adres = Replace(adres, UCase(aranan3) & ".", UCase(aranan3) & ",")
adres = Trim(adres) & AlinacakVeri

deg1 = Split(adres, AlinacakVeri)
If UBound(deg1) > 0 Then
For m = 0 To UBound(deg1) - 1
deg2 = Split(Trim(deg1(m)), " ")
If UBound(deg2) > 0 Then
sayy1 = sayy1 + 1
ara1(sayy1) = deg2(0)
ara2(sayy1) = deg2(1)
ara3(sayy1) = 0
End If
Next m
End If

veri1 = ""

For j = 1 To sayy1
aranan1 = ara1(j)
aranan2 = ara2(j)
If Val(ara3(j)) = 1 Then GoTo atla2
say1 = 0

For i = j To sayy1
If Val(ara3(i)) = 0 Then
bulunan1 = Replace(ara1(i), ".", ",")
bulunan2 = ara2(i)
If aranan2 = bulunan2 Then
say1 = say1 + CDbl(bulunan1)
ara3(i) = 1
End If
End If

Next i

veri1 = veri1 & say1 & " " & aranan2 & ", "
atla2:
Next j
Cells(r, 2).Value = Mid(veri1, 1, Len(veri1) - 2)
Next r

Application.ScreenUpdating = True
Application.DisplayAlerts = True

MsgBox "işlem tamam"

End Sub
Genişletmek için tıkla ...

Halit Bey,
Ben daha önce hiç makro yapmadım fakat internetten araştırmamla biraz çözdüm gibi en azından sizin yazdığınız formülü yerine koyup çalıştır dediğimde geliyor fakat ctrl+s yapıp dosyayı tekrar açtığımda makro kaydolmamış olarak geliyor çünkü ekte yer alan dosyadaki uyarıyı alıyorum nerde yanlış yapıyorum acaba
 

Ekli dosyalar

  • Adsız.jpg
    Adsız.jpg
    19.5 KB · Görüntüleme: 8
teşekkürler ilk fırsatta inceleyeceğim...
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst