ExcelVBA.Net sitesine katkıda bulunabilirsiniz

[Arkadasca]

.

Merhaba,

Parametreye göre farklı sayfaları tek bir sayfada birleştirmek, VBA ile mükerrer satırları kaldırıp sıralama yaptırmak istiyorum.

Ekteki dosyada işlem adımlarını izah ettim. Örnek çalışmayı yaptım.

Yardımcı olabilir misiniz?

Teşekkürler

.

[tasad]

Özet tablo sayfasındaki butona tıklamanız yeterli.

[Arkadasca]

.
Merhaba tasad,

İlginiz için çok teşekkür ederim.

Olması istenen sayfasını okuyabildiniz mi?

Buradaki talep edilenlerde bir sorun var mıdır?

RAPOR Sayfasında çalışacak şekilde düzenleme yapabilir misiniz?

Teşekkürler

[tasad]

Rapor sayfasındaki butona tıklamanız yeterli.

[Arkadasca]

.
Merhabalar,
Yardımınız için teşekkür ederim.
Gerçek dosyada, 211 satır gelmesi gerekirken sizin dosyada 210 satır geliyor.
Pazartesi günü iş yerinde detaylı araştırma yapıp sorun var ise tekrar size yazarım.

Bu arada, sanırım sizin VBA kurgunuz bizim manuel yaptığımız gibi,
Farklı bir sayfaya bütün verileri alıp buradan RAPOR sayfasına aktarım yapması gibi anladık.
Doğru mudur?

ÖZET TABLO sayfasını kullanmadan, "tek VBA modules ile" çözüme gidilebilir mi?

[tasad]

Tek modül ,tek makro.

[Arkadasca]

.
Merhabalar,
Hızlı geri dönüş ve değerli yardımlarınız için teşekkür ederim.
Sağlıcakla kalınız.

[Arkadasca]

.
Merhaba,
RAPOR sayfasında, B ile C yer değiştirilmesi gereklidir.
(Açıklama yazması gereken yere ürün adı, Ürün adı yazması gereken yere açıklama yazıyor.)

Gerçek dosyada kolon sayısı, sayfa adı, her şeyi aynı yapmama rağmen VBA çalıştıramadım.
Nereyi kontrol etmem gerekiyor?

Gerçek dosyada bir satır eksik yazıyor.
Aşağıdaki VBA Çalışma kurgusunu yazabilirseniz diğer kontrolleri de yapmak istiyorum.

Özverili yardımlarınız için teşekkür ederim.

Kod: Tümünü seç

Sub Ado()

Dim con As Object, rs As Object, rs1 As Object
On Error Resume Next
Set con = CreateObject("adodb.connection")
Sayfa8.Range("a5:C10000").ClearContents
t1 = Sayfa8.Range("a1").Value

con.Open "Provider=Microsoft.ace.oledb.12.0;Data Source=" _
& ThisWorkbook.FullName & ";Extended Properties=""Excel 12.0;hdr=no"""

For Each ss In Worksheets
If ss.Name <> "RAPOR" Then
Set rs = con.Execute("Select f4,f6,f7 from [" & ss.Name & "$] Where f5 = " & t1 & "")
Sayfa8.Range("a100000").End(3)(2, 1).CopyFromRecordset rs
End If
Next

Set rs1 = con.Execute("Select Distinct f1,f2,f3 from [RAPOR$a5:c] ")
Sayfa8.Range("a5:c10000").ClearContents
Sayfa8.Range("a100000").End(3)(2, 1).CopyFromRecordset rs1

rs.Close:
rs1.Close:
con.Close:
Set rs = Nothing:
Set rs1 = Nothing:
Set con = Nothing:
End Sub


[tasad]

Bu şekilde deneyin.

Kod: Tümünü seç

Sub Ado()

Dim con As Object, rs As Object, rs1 As Object
On Error Resume Next
Set con = CreateObject("adodb.connection")
Sheets("RAPOR").Range("a5:C10000").ClearContents
t1 = Sheets("RAPOR").Range("a1").Value

con.Open "Provider=Microsoft.ace.oledb.12.0;Data Source=" _
& ThisWorkbook.FullName & ";Extended Properties=""Excel 12.0;hdr=no"""

For Each ss In Worksheets
If ss.Name <> "RAPOR" Then
Set rs = con.Execute("Select f4,f6,f7 from [" & ss.Name & "$] Where f5 = " & t1 & "")
Sheets("RAPOR").Range("a100000").End(3)(2, 1).CopyFromRecordset rs
End If
Next

Set rs1 = con.Execute("Select Distinct f1,f3,f2 from [RAPOR$a5:c] ")
Sheets("RAPOR").Range("a5:c10000").ClearContents
Sheets("RAPOR").Range("a100000").End(3)(2, 1).CopyFromRecordset rs1

rs.Close: rs1.Close: con.Close
Set rs = Nothing: Set rs1 = Nothing: Set con = Nothing

End Sub




[Arkadasca]

.
Merhaba,

Tamamdır. İstediğimiz gibi oldu, ancak halen daha bir ürün eksik hesaplıyor.

Hangi ürün olduğunu da buldum ancak VBA kurgusu bilmediğim için daha fazla ilerleyemiyorum.

Ürünler hem harf hem de rakamlardan oluşmaktadır. EBA104K gibi...

Gerçek dosyayı da paylaşamıyorum...

Çözüm için ne önerirsiniz?

[tasad]

Kolon başlıklarında hücre birleştirme olduğu için 1 satır eksik almış.
Aşağıdaki kodu deneyin.

Kod: Tümünü seç

Sub Ado()

Dim con As Object, rs As Object, rs1 As Object
On Error Resume Next
Set con = CreateObject("adodb.connection")
Sheets("RAPOR").Range("a5:C10000").ClearContents
t1 = Sheets("RAPOR").Range("a1").Value

con.Open "Provider=Microsoft.ace.oledb.12.0;Data Source=" _
& ThisWorkbook.FullName & ";Extended Properties=""Excel 12.0;hdr=no"""

For Each ss In Worksheets
If ss.Name <> "RAPOR" Then
Set rs = con.Execute("Select f4,f6,f7 from [" & ss.Name & "$] Where f5 = " & t1 & "")
Sheets("RAPOR").Range("a100000").End(3)(3, 1).CopyFromRecordset rs
End If
Next

Set rs1 = con.Execute("Select Distinct f1,f3,f2 from [RAPOR$a5:c] ")
Sheets("RAPOR").Range("a5:c10000").ClearContents
Sheets("RAPOR").Range("a100000").End(3)(3, 1).CopyFromRecordset rs1

rs.Close: rs1.Close: con.Close
Set rs = Nothing: Set rs1 = Nothing: Set con = Nothing

End Sub




[Arkadasca]

.
Merhabalar,

Tamamdır, bu sefer oldu.
Eksik olan ürün de geldi, kontrol ettim, satır sayısı da tutuyor. Teşekkür ederim. Emeğinize sağlık.

Ancak bu sefer de A5, B5, C5 Yazması gerekirken bir alt satırdan başlayarak yazıyor.
Kusura bakmayın sizi de uğraştırıyorum. Eğer düzeltebilirsek iyi olur.
Yoksa gerisini ben de halledebilirim.

[tasad]

Kod: Tümünü seç

Sub Ado()

Dim con As Object, rs As Object, rs1 As Object
On Error Resume Next
Set con = CreateObject("adodb.connection")
Sheets("RAPOR").Range("a5:C10000").ClearContents
t1 = Sheets("RAPOR").Range("a1").Value

con.Open "Provider=Microsoft.ace.oledb.12.0;Data Source=" _
& ThisWorkbook.FullName & ";Extended Properties=""Excel 12.0;hdr=no"""

For Each ss In Worksheets
If ss.Name <> "RAPOR" Then
Set rs = con.Execute("Select f4,f6,f7 from [" & ss.Name & "$] Where f5 = " & t1 & "")
Sheets("RAPOR").Range("a100000").End(3)(2, 1).CopyFromRecordset rs
End If
Next

Set rs1 = con.Execute("Select Distinct f1,f3,f2 from [RAPOR$a5:c] ")
Sheets("RAPOR").Range("a5:c10000").ClearContents
Sheets("RAPOR").Range("a100000").End(3)(3, 1).CopyFromRecordset rs1

rs.Close: rs1.Close: con.Close
Set rs = Nothing: Set rs1 = Nothing: Set con = Nothing

End Sub




[Arkadasca]

.
Merhaba,
Çok teşekkür ederim.
Esenlikle kalınız.

.