Merhabalar,
Aşağıdaki kodu internetten buldum (kodu Feyzullah hocam yazmıştır). Dosya ismi oluşturup masa üstüne kaydedebiliyorum, fakat sadece değerler geliyor. Dosyada renklendirme varsa olmadı bir türlü koşullu alanın verse renklendirme değerleri ile gelsin istiyorum.
yardımcı olabilirseniz sevinirim.
Saygılarımla.
Sub Kaydet()
'www.************* XXxxXXxxXX
Set con = CreateObject("Adodb.Connection")
Set rs = CreateObject("Adodb.Recordset")
sayfa = "Saat Bazlı Uyum" ' sayfa adını buraya yaz.
con.Open "provider=microsoft.ace.oledb.12.0;data source=" & _
ThisWorkbook.FullName & ";extended properties=""Excel 12.0;hdr=yes"""
sorgu = "select distinct (isimler) from [" & sayfa & "$a1:d65536]"
rs.Open sorgu, con, 1, 1
If rs.RecordCount > 0 Then
Do While Not rs.EOF
adi = rs(0).Value
'isimlere göre sayfa oluştur
Sheets.Add After:=Sheets(Sheets.Count)
ActiveSheet.Name = adi
Set bag = CreateObject("Adodb.Connection")
bag.Open "provider=microsoft.ace.oledb.12.0;data source=" & _
ThisWorkbook.FullName & ";extended properties=""Excel 12.0;hdr=yes"""
Set kayit = CreateObject("Adodb.Recordset")
s = "select * from [" & sayfa & "$a1:d65536] where (isimler) = '" & adi & "'"
kayit.Open s, bag, 1, 1
On Error Resume Next
For i = 0 To kayit.Fields.Count 'SUTUN BAŞLIKLARI İÇİN
Cells(1, i + 1).Value = kayit.Fields(i).Name 'SUTUN BAŞLIKLARI İÇİN
Next i 'SUTUN BAŞLIKLARI İÇİN
On Error GoTo 0
If kayit.RecordCount > 0 Then
Range("a2").CopyFromRecordset kayit
End If
kayit.Close: bag.Close
'OLUŞTURULAN DOSYAYI MASAUSTUNE KAYDET
On Error Resume Next
Set WS = CreateObject("WScript.Shell")
desk = WS.SpecialFolders("Desktop")
Sheets(adi).Copy
Sheets(adi).SaveAs desk & "\" & adi & ".xlsx"
ActiveWorkbook.Close
Application.DisplayAlerts = False
Sheets(adi).Delete
Application.DisplayAlerts = True
On Error GoTo 0
'OLUŞTURULAN DOSYAYI MASAUSTUNE KAYDET
say = say + 1
rs.movenext
Loop
End If
MsgBox "İşlem tamam " & say & " adet dosya masaüstüne kaydedildi", vbInformation + vbMsgBoxRtlReading, "Dosya Kaydetme"
rs.Close: con.Close
Set rs = Nothing: Set con = Nothing
End Sub
Aşağıdaki kodu internetten buldum (kodu Feyzullah hocam yazmıştır). Dosya ismi oluşturup masa üstüne kaydedebiliyorum, fakat sadece değerler geliyor. Dosyada renklendirme varsa olmadı bir türlü koşullu alanın verse renklendirme değerleri ile gelsin istiyorum.
yardımcı olabilirseniz sevinirim.
Saygılarımla.
Sub Kaydet()
'www.************* XXxxXXxxXX
Set con = CreateObject("Adodb.Connection")
Set rs = CreateObject("Adodb.Recordset")
sayfa = "Saat Bazlı Uyum" ' sayfa adını buraya yaz.
con.Open "provider=microsoft.ace.oledb.12.0;data source=" & _
ThisWorkbook.FullName & ";extended properties=""Excel 12.0;hdr=yes"""
sorgu = "select distinct (isimler) from [" & sayfa & "$a1:d65536]"
rs.Open sorgu, con, 1, 1
If rs.RecordCount > 0 Then
Do While Not rs.EOF
adi = rs(0).Value
'isimlere göre sayfa oluştur
Sheets.Add After:=Sheets(Sheets.Count)
ActiveSheet.Name = adi
Set bag = CreateObject("Adodb.Connection")
bag.Open "provider=microsoft.ace.oledb.12.0;data source=" & _
ThisWorkbook.FullName & ";extended properties=""Excel 12.0;hdr=yes"""
Set kayit = CreateObject("Adodb.Recordset")
s = "select * from [" & sayfa & "$a1:d65536] where (isimler) = '" & adi & "'"
kayit.Open s, bag, 1, 1
On Error Resume Next
For i = 0 To kayit.Fields.Count 'SUTUN BAŞLIKLARI İÇİN
Cells(1, i + 1).Value = kayit.Fields(i).Name 'SUTUN BAŞLIKLARI İÇİN
Next i 'SUTUN BAŞLIKLARI İÇİN
On Error GoTo 0
If kayit.RecordCount > 0 Then
Range("a2").CopyFromRecordset kayit
End If
kayit.Close: bag.Close
'OLUŞTURULAN DOSYAYI MASAUSTUNE KAYDET
On Error Resume Next
Set WS = CreateObject("WScript.Shell")
desk = WS.SpecialFolders("Desktop")
Sheets(adi).Copy
Sheets(adi).SaveAs desk & "\" & adi & ".xlsx"
ActiveWorkbook.Close
Application.DisplayAlerts = False
Sheets(adi).Delete
Application.DisplayAlerts = True
On Error GoTo 0
'OLUŞTURULAN DOSYAYI MASAUSTUNE KAYDET
say = say + 1
rs.movenext
Loop
End If
MsgBox "İşlem tamam " & say & " adet dosya masaüstüne kaydedildi", vbInformation + vbMsgBoxRtlReading, "Dosya Kaydetme"
rs.Close: con.Close
Set rs = Nothing: Set con = Nothing
End Sub
