Sayfa'lardaki Verileri Tek Sayfa Aktarma İşlemi

[baba]

Arkadaşlar Merhaba;

Göndermiş olduğum çalışmada GENEL sayfası olan Yere Rakam ile belirtilmiş olduğum sayfadaki verileri GENEL sayfaya aktarma işlemin nasıl gerçekleştirebiliriz.

Not: Rakamlı Sayfalardaki veriler Düzeli değildir.Ama Aktarma işleminde ise Veri isimlerine göre aktarma yapılması...

 

[Tarkan VURAL]

Yanıt

Merhaba,

Aşağıdaki kodlama işinizi görür:

Sub aktar()
On Local Error Resume Next
Rem Tarkan VURAL
Rem 30-07-2009
Dim t As Worksheet, i As Integer, sat As Long, sayfa As String
Dim adres As String, con As Object, rs As Object, son As Long
Application.DisplayAlerts = False
Sheets("TUM").Delete
Sheets.Add.Name = "TUM"
Set t = Sheets("TUM")
t.Range("A1").Value = "MALZEMEADI"
t.Range("B1").Value = "GENELTOPLAM"
For i = 1 To Sheets.Count
sayfa = Sheets(i).Name
Select Case sayfa
Case Is = "TUM", "DATASAYFASI", "LABORATUVAR", "RÖNTGEN", "GENEL"
Case Else
sat = Sheets(sayfa).Range("a65536").End(3).Row
adres = "a10:b" & sat
Sheets(sayfa).Range(adres).Copy
t.Range("a65536").End(3)(2, 1).PasteSpecial xlPasteValues
Application.CutCopyMode = False
End Select
Next i
son = t.Range("a65536").End(3).Row
t.Range("b" & son & ":b65536").ClearContents
    t.Columns("A:A").Replace What:="'", Replacement:="", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
    Sheets("GENEL").Columns("b:b").Replace What:="'", Replacement:="", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
Set con = CreateObject("adodb.connection")
con.Open "provider=microsoft.jet.oledb.4.0;data source=" & ThisWorkbook.FullName & ";" & _
"extended properties=""excel 8.0;hdr=yes"""
    For i = 7 To Sheets("GENEL").Range("b65536").End(3).Row
        Set rs = con.Execute("select sum(GENELTOPLAM) as toplam from [TUM$] where MALZEMEADI='" & Sheets("GENEL").Cells(i, "b").Value & "'")
        Sheets("GENEL").Cells(i, "c").CopyFromRecordset rs
    Next i
        Sheets("TUM").Delete
        Application.DisplayAlerts = True
    MsgBox "İşlem tamamlanmıştır.   ", vbInformation, "Tarkan VURAL"
Set con = Nothing: Set t = Nothing: Set rs = Nothing
i = Empty: son = Empty: sat = Empty
sayfa = vbNullString: adres = vbNullString
End Sub

Örnek dosyayı indirip deneyebilirsiniz.
İyi çalışmalar diliyorum.

 

[baba]

teşekkürler ederim ellerinize sağlık