Bir sayfadaki benzer isimdeki verilerin başka bir sayfaya aktarılması

[mücahitayan]

Dosyam ektedir. Yardımcı olabilirseniz çok memnun olurum.

Iyi çalışmalar dilerim.

 

[fedeal]

Sub fdl()
Dim d, bs As Integer
Dim i, h As Long
Dim s1, s2, s3 As Worksheet
Set s1 = Sheets("YEVMİYE")
Set s2 = Sheets("FİRMA KAYIT")
Set s3 = Sheets("RAPORLAMA")
s2.Cells(1, "z").Value = s1.Cells(18, "I").Value
d = s2.Cells(1, "aa").Value
son = s1.Range("A65000").End(xlUp).Row
For i = 3 To son
If s1.Cells(i, 3).Value = s1.Cells(18, "I").Value Then
bs = s3.Range("A65000").End(xlUp).Row + 1
For h = 1 To 15
s3.Cells(bs, h).Value = s2.Cells(d, h).Value
Next
s3.Cells(bs, 16).Value = s1.Cells(i, 4).Value
s3.Cells(bs, 17).Value = s1.Cells(i, 7).Value
End If
Next
End Sub

iyi çalışmalar.

 

[fedeal]

Sub fdl()
Dim d As Double
Dim bs As Integer
Dim i, h As Long
Dim s1, s2, s3 As Worksheet
Set s1 = Sheets("YEVMİYE")
Set s2 = Sheets("FİRMA KAYIT")
Set s3 = Sheets("RAPORLAMA")
d = WorksheetFunction.Match(s1.Cells(18, "I").Value, s2.Range("c1:c65000"), 0)
son = s1.Range("A65000").End(xlUp).Row
For i = 3 To son
If s1.Cells(i, 3).Value = s1.Cells(18, "I").Value Then
bs = s3.Range("A65000").End(xlUp).Row + 1
For h = 1 To 15
s3.Cells(bs, h).Value = s2.Cells(d, h).Value
Next
s3.Cells(bs, 16).Value = s1.Cells(i, 4).Value
s3.Cells(bs, 17).Value = s1.Cells(i, 7).Value
End If
Next
End Sub

bu kodu kullanırsanız sayfadaki formule ihtiyaç kalmayacak ,saygılar.

 

[mücahitayan]

sayın fedeal makro için çok teşekkür ederim.

yalnız orda özellikle belirtmek istediğim birşey var. ben 2. sayfaya kaydı aldığım zaman aynı AD ile olan yerlerin KG kısımlarını toplayıp tek olarak yazmasını istiyorum.

inşllh. anlatabilmişimdir. şimdiden bu yardımlarınız için teşekkür ederim.

 

[fedeal]

Sub fdl()
Dim d As Double
Dim bs As Integer
Dim i, h As Long
Dim s1, s2, s3 As Worksheet
Set s1 = Sheets("YEVMİYE")
Set s2 = Sheets("FİRMA KAYIT")
Set s3 = Sheets("RAPORLAMA")
d = WorksheetFunction.Match(s1.Cells(18, "I").Value, s2.Range("c1:c65000"), 0)
bs = s3.Range("A65000").End(xlUp).Row + 1
For h = 1 To 15
s3.Cells(bs, h).Value = s2.Cells(d, h).Value
Next
son = s1.Range("A65000").End(xlUp).Row
For i = 3 To son
If s1.Cells(i, 3).Value = s1.Cells(18, "I").Value Then
s3.Cells(bs, 16).Value = s3.Cells(bs, 16).Value + s1.Cells(i, 4).Value
s3.Cells(bs, 17).Value = s3.Cells(bs, 17).Value + s1.Cells(i, 8).Value
End If
Next
End Sub

tek satırda topluyor.iyi çalışmalar.

 

[mücahitayan]

çok teşekkür ederim. saolun elinize sağlık çok güzel oldu.

böle perakende perakende oluyor ama kusura bakmayın :S bi sorunum daha var.

orda şirketi "TÜMÜ" olarak seçtiğimde farklı isimlerdekilerin tamamını toplayıp alt alta raporlayabilir mi :S

 

[fedeal]

Sub fd()
Dim d As Double
Dim bs As Integer
Dim i As Long
Dim s1, s2, s3 As Worksheet
Set s1 = Sheets("YEVMİYE")
Set s2 = Sheets("FİRMA KAYIT")
Set s3 = Sheets("RAPORLAMA")
For i = 3 To s1.Range("A65000").End(xlUp).Row
If WorksheetFunction.CountIf(s3.Range("c3:c65000"), s1.Cells(i, 3).Value) >= 1 Then
Else
d = WorksheetFunction.Match(s1.Cells(i, 3).Value, s2.Range("c1:c65000"), 0)
bs = s3.Range("A65000").End(xlUp).Row + 1
For h = 1 To 15
s3.Cells(bs, h).Value = s2.Cells(d, h).Value
Next
s3.Cells(bs, "p").Value = WorksheetFunction.SumIf(s1.Range("c3:c65000"), s1.Cells(i, 3).Value, s1.Range("d3:d65000"))
s3.Cells(bs, "q").Value = WorksheetFunction.SumIf(s1.Range("c3:c65000"), s1.Cells(i, 3).Value, s1.Range("h3:h65000"))
End If
Next
End Sub

başka bir butona atayın,iyi çalışmalar.

 

[mücahitayan]

d = WorksheetFunction.Match(s1.Cells(i, 3).Value, s2.Range("c1:c65000"), 0)


bu satırda hata verdi :S ama...


ya kusura bakmıyorsunuz inşllh.

 

[fedeal]

Sub fd()
Dim d As Double
Dim bs As Integer
Dim i As Long
Dim s1, s2, s3 As Worksheet
Set s1 = Sheets("YEVMİYE")
Set s2 = Sheets("FİRMA KAYIT")
Set s3 = Sheets("RAPORLAMA")
For i = 3 To s1.Range("A65000").End(xlUp).Row
If WorksheetFunction.CountIf(s3.Range("c3:c65000"), s1.Cells(i, 3).Value) >= 1 Then
Else
    Set bul = s2.Range("c1:c65000").Find(s1.Cells(i, 3).Value)
    If Not bul Is Nothing Then
            d = bul.Row
bs = s3.Range("A65000").End(xlUp).Row + 1
For h = 1 To 15
s3.Cells(bs, h).Value = s2.Cells(d, h).Value
Next
s3.Cells(bs, "p").Value = WorksheetFunction.SumIf(s1.Range("c3:c65000"), s1.Cells(i, 3).Value, s1.Range("d3:d65000"))
s3.Cells(bs, "q").Value = WorksheetFunction.SumIf(s1.Range("c3:c65000"), s1.Cells(i, 3).Value, s1.Range("h3:h65000"))
End If
End If
Next
End Sub

bunu kullanın findle yaptım,saygılar.