Firmaya göre Verileri Sayfalara aktarmak

[excelturk]

Değerli ustalar ekteki dosyada veri sayfasındaki bilgileri aktar butonunu kullanarak firmalara göre diğer sayfalarak aktarmasını sağlamak ve tutarı otomatik olarak aldırmak istiyrorum. Beni için bu çok önemli Yardımlarınız için şimdiden teşekkürler

 

[Zeki Gürsoy]

Sub Test()
Dim cn As Object, rs As Object
Dim array_accounts$(), i%

Set cn = CreateObject("adodb.connection")
Set rs = CreateObject("adodb.recordset")

cn.Open _
"driver={microsoft excel driver (*.xls)};dbq=" & ThisWorkbook.FullName

rs.Open _
    "select distinct [FİRMA ADI] from [VERİ$]", cn, 1, 3
 
While Not rs.EOF
    i = i + 1
    ReDim Preserve array_accounts$(i - 1)
    array_accounts(i - 1) = rs(0)
    rs.movenext
Wend

On Error Resume Next

Application.DisplayAlerts = False

For i = 0 To UBound(array_accounts)
    Worksheets.Add after:=Sheets(Sheets.Count)
    Sheets(Sheets.Count).Name = array_accounts(i)
    Sheets("VERİ").[a1:e1].Copy Sheets(Sheets.Count).[a1]
    If Err Then Sheets(Sheets.Count).Delete: Err.Clear
Next

Application.DisplayAlerts = True

For i = 0 To UBound(array_accounts)
    Set rs = cn.Execute( _
    "select * from [VERİ$] where [FİRMA ADI] ='" & array_accounts(i) & "'")
     Sheets("" & array_accounts(i)).[a2:e65536].ClearContents
    Sheets("" & array_accounts(i)).[a2].CopyFromRecordset rs
Next

rs.Close
cn.Close

Erase array_accounts

Set rs = Nothing
Set cn = Nothing
End Sub

 

[excelturk]

Zeki Bey çok teşekkür ederim ama aşağıdaki kodda hata veriyor bakar mısınız

array_accounts(i - 1) = rs(0)

 

[Zeki Gürsoy]

Tekrar test ettim. Sorun görünmüyor.

 

[tahsinanarat]

E20 HÜcresİne Toplam Aldirma

Sn. excelturk toplamları e1 hücresine alsa, yada belirlediğin herhangi bir satır (e50) gibi olsu uygun olurmu,

 

[devrialem]

güzel çalışma.. emeğinize sağlık

 

[excelturk]

Sayın Tahsinaranat Toplamları alıyor ama sütun (tutar) toplamını hatalı alıyor ayrıca Aktarılan sayfalara alınan toplamların toplamı veri Sayfasının Tutar toplamına eşit olması gerekiyor. Kodları kontrol ettim ama çozemedim Formüle edecek olursak (veri girişlerine esnek olmalı)
VERİ (Tutar Toplamı)=AAA +ABC +ACC +DEA
şeklinde olması gerekiyor

İlgilenirsen sevinirim Teşeşkürler

 

[tahsinanarat]

Kodu silip, aşağıdaki kodları yapıştırınız. Kolay gelsin
Not: yukarıdaki dosyayı da güncelledim
Sub Test()
Dim cn As Object, rs As Object
Dim array_accounts$(), i%
Set cn = CreateObject("adodb.connection")
Set rs = CreateObject("adodb.recordset")
cn.Open _
"driver={microsoft excel driver (*.xls)};dbq=" & ThisWorkbook.FullName
rs.Open _
"select distinct [FİRMA ADI] from [VERİ$]", cn, 1, 3

While Not rs.EOF
i = i + 1
ReDim Preserve array_accounts$(i - 1)
array_accounts(i - 1) = rs(0)
rs.movenext
Wend
On Error Resume Next
Application.DisplayAlerts = False
For i = 0 To UBound(array_accounts)
Worksheets.Add after:=Sheets(Sheets.Count)
Sheets(Sheets.Count).Name = array_accounts(i)
Sheets("VERİ").[a1:e1].Copy Sheets(Sheets.Count).[a1]
If Err Then Sheets(Sheets.Count).Delete: Err.Clear
Next
Application.DisplayAlerts = True
For i = 0 To UBound(array_accounts)
Set rs = cn.Execute( _
"select * from [VERİ$] where [FİRMA ADI] ='" & array_accounts(i) & "'")
Sheets("" & array_accounts(i)).[a2:e65536].ClearContents
Sheets("" & array_accounts(i)).[a2].CopyFromRecordset rs
Next
For X = 2 To Sheets.Count
For Y = 5 To 5
Sheets(X).Cells(25, Y) = WorksheetFunction.Sum(Sheets(X).Range(Sheets(X).Cells(2, Y), Sheets(X).Cells(25, Y)))
Next
Next
rs.Close
cn.Close
Erase array_accounts
Set rs = Nothing
Set cn = Nothing
MsgBox "İŞLEMİNİZ TAMAMLANMIŞTIR.", vbInformation
End Sub

 

[shadowfox]

benimde buna benzer bi sorunum var ben de bu tarz bir şey yapmaya çalışıyordum müşterilere göre farklı sheetlere ayırmasını istiyorum fakat her seferinde eski sheetleri silip yenisini oluşturmasın varolan sayfayı update etsin istiyorum çünkü yeni oluşturulan sheet lerde değişiklik yapılabilir olmalı ve butona tekrar tıkladığımda o sonradan girilen değerler değişmemeli yardım edebilirseniz çok sevinirim şimdiden teşekkür ederim

 

[cenderus]

bu konuya ilişkin dosya tekrar eklenmiştir

bu konuya ilişkin dosya tekrar eklenmiştir