Makro İle Dosya Oluşturma

[baydeniro]

Merhaba arkadaşlar. Makro kodu ile belli bir katalog altında satırdaki bilgilere göre farklı farklı dosyalar oluşturulabilir mi ?

Örnek dosya ektedir.

 

[baydeniro]

Arkadaşlar, bu konu ile ilgili bilgisi olan var mı !!

 

[halit3]

bu kodu denermisiniz

Sub satırdakidegerleridosyayap()
On Error Resume Next
Dim Baslik As String
Baslik = "Kaynak Dosyaları İçeren Klasörü Seçin"
Set Obj = CreateObject("shell.application")
Set Klasor = Obj.BrowseForFolder(0, Baslik, 50, &H0)
kaynak = Klasor.items.Item.Path
If Len(kaynak) = 3 Then
kaynak = Mid(kaynak, 1, 2)
Else
kaynak = kaynak
End If
If Not Klasor Is Nothing Then
If InStr(1, kaynak, "{") > 0 Then GoTo Atla
On Error Resume Next
For i = 3 To WorksheetFunction.CountA(Worksheets(ActiveSheet.Name).Range("B3:B65000")) + 3
If Sheets(ActiveSheet.Name).Cells(i, 2).Value > 0 Then
yeni_dosya_adı = Sheets(ActiveSheet.Name).Cells(i, 2).Value
Dim ExcelSheet As Object
On Error Resume Next
CreateObject("Excel.Sheet").SaveAs kaynak & "\" & yeni_dosya_adı & ".xls"
End If
Next
MsgBox "işlem tamam"
Else
Atla:
MsgBox "Lütfen Kaynak Klasör Seçimini Yapınız !", vbInformation, "DİKKAT"
End If
End Sub

 

[baydeniro]

Sayın halit3 çok çok teşekkür ederim. Allah sizden razı olsun. Elleriniz dert görmesin.

 

[baydeniro]

Sayın halit3.

1) Kayıt olacak klasörü makro kodunun içinde gösterme olanağı var mı ?
2) Yeni kitaplar açılırken satırdaki bilgilerin de kopyalanması mümkün olabilir mi ?

 

[halit3]

bu kodu denermisin örnek olarak c sürücüsünün içine deneme adlı klasörü yoksa kendisi oluşturuyor varsa içine dosyaları aktarıyor

kod aşağıdaki mesajda

 

[baydeniro]

Sayın halit3 yardımalarınız için çok teşekkür ederim. Bir de satırdaki bilgileri kopyalama yapabilirse harika olacak.

 

[halit3]

aşağıdaki mesajda

 

[baydeniro]

Sayın halit3 ilginiz için çok teşekkür ederim. Size zahmet verdim. Kopyalarken satırdaki bilgileri aktarmıyor.

 

[halit3]

işlem yapıyor

Sub satırdakidegerleridosyayap1()
klasör_adı = "C:\deneme"
On Error Resume Next
If Dir(klasör_adı) = "" Then MkDir klasör_adı
On Error Resume Next
For i = 3 To WorksheetFunction.CountA(Worksheets(ActiveSheet.Name).Range("B3:B65000")) + 3
If Sheets(ActiveSheet.Name).Cells(i, 2).Value > 0 Then
yeni_dosya_adı = Sheets(ActiveSheet.Name).Cells(i, 2).Value
Dim ExcelSheet As Object
On Error Resume Next
CreateObject("Excel.Sheet").SaveAs klasör_adı & "\" & yeni_dosya_adı & ".xls"
End If
Next
ActiveWindow.WindowState = xlMaximized
aktar
End Sub
Sub aktar()
Sayfa_adı = "Sayfa1"
klasör_adı = "C:\deneme\"
Set Klasor = CreateObject("Excel.Application")
Set ker = CreateObject("Excel.Application")
For i = 3 To WorksheetFunction.CountA(Worksheets(ActiveSheet.Name).Range("B3:B65000")) + 2
If Sheets(ActiveSheet.Name).Cells(i, 2).Value > 0 Then
yeni_dosya_adı = Sheets(ActiveSheet.Name).Cells(i, 2).Value & ".xls"
Klasor.Workbooks.Open (klasör_adı & yeni_dosya_adı)
Set Dosya = Klasor.Workbooks(yeni_dosya_adı).Sheets(Sayfa_adı)
Dosya.Cells(i, 3) = Cells(i, 2)
Dosya.Cells(i, 3) = Cells(i, 3)
Dosya.Cells(i, 4) = Cells(i, 4)
End If
Klasor.Workbooks(yeni_dosya_adı).Save
Klasor.Workbooks(yeni_dosya_adı).Close
Next i
Set Klasor = Nothing
Set Dosya = Nothing
MsgBox "işlem tamam"
End Sub

 

[baydeniro]

Sayın halit3 çok çok teşekkür ederim. Size zahmet verdim. Ben kodu kendi dosyama uyguladım, nasıl olduysa orada çalışmamıştı. Eklediğiniz dosya çok yararlı oldu. Çok çok teşekkür ederim, elleriniz dert görmesin. Sağlıcakla kalın.

 

[halit3]

iyi çalışmalar

 

[aykutovski]

Arkadaşlar kod compile error: syntax error veriyor:
Satır: For i = 3 To WorksheetFunction CountA(Worksheets(ActiveSheet.Na me).Range("B3:B65000")) + 3

 

[aliaslanali]

bir veriyi aynı anda birkaç bilgisayarda görmek için ne yapmalıyız

 

[halit3]

Arkadaşlar kod compile error: syntax error veriyor:
Satır: For i = 3 To WorksheetFunction CountA(Worksheets(ActiveSheet.Na me).Range("B3:B65000")) + 3

Na me yazan yerin arasındaki boşluğu kaldrın Name olarak yazın sisteme kodları aktarınca burada boşluk oluşuyor ondan kırmızı renk oluyor hata veriyor