tek sheetten yeni sheetler oluşturarak verileri kopyalama

[timik]

Merhaba uzmanlar,

Bir konuda desteğe ihtiyacım var, her hafta karşılaştığım saatlerce uğraştığım sorunu macro ile çözümlemek istiyorum. tek sheette 40bin satırlık veri mevcut. AA sheetinde yer alan A stünundaki masraf yeri bazında isimlerle yeni sheetler oluşturup, oluşan her sheete ilgili masraf yerlerinin karşısında bulunan verilerin(her bir masraf yerinin 500 ile 520 satırlık farklı verileri var) hepsini atmak istmekteyim. Bu kouda yardımıcı olabilirseni çok sevinirim.

 

[timik]

otomatik olarak sayfa oluşturmak için macro sitenizde buldum, verileri yeni oluşturulan sheetlere macro ile kopyalamayı bulubilirsem sorunum çömümlenir gibi.



Sub sayfaoluştur()
git = ActiveSheet.Name
For i = 2 To WorksheetFunction.CountA(Worksheets("Sayfa1").Range("A2:A65000")) + 1
yer = Worksheets("Sayfa1").Cells(i, 1).Value
deger = 0
For r = 1 To ActiveWorkbook.Sheets.Count
If Sheets(r).Name = yer Then
deger = 1
End If
Next r
If deger <> 1 Then
Sheets.Add
On Error Resume Next
Sheets(ActiveSheet.Name).Name = yer
Sheets(yer).Move After:=Sheets(ActiveWorkbook.Sheets.Count)
End If
Next i
Sheets(git).Select
MsgBox "işlem tamam"
End Sub

 

[timik]

Merhaba,

yine sayfanızdan istediğim kodları buldum. teşekkürler


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 [SUBE KODU] from [VERİ$]", cn, 1, 3

While Not rs.EOF
i = i + 1
On Error Resume Next
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 [SUBE KODU] ='" & 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

 

[ozlemaltin]

dosyanın son halini paylaşırmısınız. selamlar tşkler, özlem