bir sayfayı başka dosya olarak kaydetme

[senselcuksen]

Arkadaşlar,

Aşağıdaki kodu,

For j = 1 To 200
If Cells(4, j).Value = ComboBox1.Value Then
Sheets("format").Copy After:=Sheets(1)
ActiveSheet.Name = InputBox("DOSYA ADINI GİRİNİZ", _
"Yeni Sayfa Ad", "YeniSayfa Ekle")
kk = ActiveSheet.Name

c:belgelerim içine excel dosyası olarak kaydetmek istiyorum. bir de yazdığım dosya adı, günün tarihi ile beraber üst bilgi olarak atansın.
yardımlarınız için çok tşk

 

[senselcuksen]

yardım lütfen

 

[senselcuksen]

tıkandım. ltf yardımmm

 

[emrexcel123]

yanlış anlamadıysam herhangi bir sayfayı tek bir excel dosyası olarak kaydetmesini istiyorsun değil mi?

 

[senselcuksen]

evet, dosya adını ben gireceğim, dosya adı ile c:belgelerme kaydedilecek. bir de excelin üst bilgisinde girdiğim dosya adı ve günün tarihi olacak.

tşk

 

[emrexcel123]

dosya yolunu verir misin ayrıca excelin üst bilgisinden kastınız nedir anlayamadım ?

 

[senselcuksen]

dosya çok büyük mevut kodları yollayabilirim.

üst bilgiden kastım, sayfa düzeni/sayfa yapısının içindeki üst bilgi fonk. yani her sayfada görünsün.

Private Sub ComboBox1_Change()
Dim i As Integer
For i = 24 To 44
Sheets("hedef2007").Select
ComboBox1.AddItem Cells(4, i).Value
Next i
End Sub

Private Sub CommandButton1_Click()
Dim j As Integer
Dim k As Integer
Dim x As Integer
Dim aa As Integer
Dim bb As Integer
Dim ss As Integer
Dim sel As Integer
Dim kk
For j = 1 To 200
If Cells(4, j).Value = ComboBox1.Value Then
Sheets("format").Copy After:=Sheets(1)
ActiveSheet.Name = InputBox("DOSYA ADINI GİRİNİZ", _
"Yeni Sayfa Ad", "YeniSayfa Ekle")
kk = ActiveSheet.Name


For x = 1 To 1000
If Sheets("hedef2007").Cells(x, j).Value = "S" Then

k = 3
A: k = k + 1
If Sheets(kk).Cells(k, 4) = "" Then
ActiveSheet.Cells(k, 4).Value = Sheets("hedef2007").Cells(x, 5).Value
ActiveSheet.Cells(k, 1).Value = Sheets("hedef2007").Cells(x, 1).Value
ActiveSheet.Cells(k, 2).Value = Sheets("hedef2007").Cells(x, 2).Value
ActiveSheet.Cells(k, 3).Value = Sheets("hedef2007").Cells(x, 3).Value
ActiveSheet.Cells(k, 7).Value = Sheets("hedef2007").Cells(x, 6).Value
ActiveSheet.Cells(k, 8).Value = Sheets("hedef2007").Cells(x, 7).Value
ActiveSheet.Cells(k, 9).Value = Sheets("hedef2007").Cells(x, 45).Value




Else: GoTo A


End If
End If
If Sheets("hedef2007").Cells(x, j).Value = "D" Then

k = 3
B: k = k + 1
If Sheets(kk).Cells(k, 4) = "" Then
ActiveSheet.Cells(k, 4).Value = Sheets("hedef2007").Cells(x, 5).Value
ActiveSheet.Cells(k, 1).Value = Sheets("hedef2007").Cells(x, 1).Value
ActiveSheet.Cells(k, 2).Value = Sheets("hedef2007").Cells(x, 2).Value
ActiveSheet.Cells(k, 3).Value = Sheets("hedef2007").Cells(x, 3).Value
ActiveSheet.Cells(k, 4).Value = Sheets("hedef2007").Cells(x, 5).Value
ActiveSheet.Cells(k, 7).Value = Sheets("hedef2007").Cells(x, 6).Value
ActiveSheet.Cells(k, 8).Value = Sheets("hedef2007").Cells(x, 7).Value
ActiveSheet.Cells(k, 9).Value = Sheets("hedef2007").Cells(x, 45).Value


Else: GoTo B


End If
End If

Next x



End If
Next j
For aa = 4 To 300
For bb = 4 To 300

If Sheets(kk).Cells(aa, 4).Value = Sheets("hedef2007").Cells(bb, 5).Value Then

For ss = 24 To 44

If Sheets("hedef2007").Cells(bb, ss).Value = "S" Then
Sheets(kk).Cells(aa, 5) = IIf(Sheets(kk).Cells(aa, 5) = "", Sheets("hedef2007").Cells(4, ss).Value, Sheets(kk).Cells(aa, 5) & "," & Sheets("hedef2007").Cells(4, ss).Value)

End If
If Sheets("hedef2007").Cells(bb, ss).Value = "D" Then
Sheets(kk).Cells(aa, 6) = IIf(Sheets(kk).Cells(aa, 6) = "", Sheets("hedef2007").Cells(4, ss).Value, Sheets(kk).Cells(aa, 6) & "," & Sheets("hedef2007").Cells(4, ss).Value)

End If
Next ss

End If

Next bb
Next aa



MsgBox " Hedef Kartı Oluşturulmuştur..."
End Sub

 

[senselcuksen]

dosya yolu:

c:/belgelerim

 

[emrexcel123]

Sub farkli_kaydet()
kyt = InputBox("DOSYA ADI GİRİNİZ..", "DOSYA ADI")
Sheets("sayfa1").Copy
adr = "C:\belgelerim\" & kyt
ActiveWorkbook.SaveAs adr
ActiveWorkbook.Close True
End Sub
bu kodu dener misin ?

 

[senselcuksen]

ok fakat üst bilgi prolemini nasıl çözeceğiz?

 

[emrexcel123]

kod

arkadaşım şu kodu dener misin ?
Sub farkli_kaydet()
On Error Resume Next
kyt = InputBox("DOSYA ADI GİRİNİZ..", "DOSYA ADI")
Sheets("sayfa1").Copy
adr = "C:\belgelerim\" & kyt
ActiveWorkbook.SaveAs adr
With ActiveSheet.PageSetup
.PrintTitleRows = ""
.PrintTitleColumns = ""
End With
ActiveSheet.PageSetup.PrintArea = ""
With ActiveSheet.PageSetup
.LeftHeader = kyt
.CenterHeader = "&D"
.RightHeader = ""
.LeftFooter = ""
.CenterFooter = ""
.RightFooter = ""
.LeftMargin = Application.InchesToPoints(0.75)
.RightMargin = Application.InchesToPoints(0.75)
.TopMargin = Application.InchesToPoints(1)
.BottomMargin = Application.InchesToPoints(1)
.HeaderMargin = Application.InchesToPoints(0.5)
.FooterMargin = Application.InchesToPoints(0.5)
.PrintHeadings = False
.PrintGridlines = False
.PrintComments = xlPrintNoComments
.CenterHorizontally = False
.CenterVertically = False
.Orientation = xlPortrait
.Draft = False
.PaperSize = xlPaperA4
.FirstPageNumber = xlAutomatic
.Order = xlDownThenOver
.BlackAndWhite = False
.Zoom = 100
.PrintErrors = xlPrintErrorsDisplayed
End With
ActiveWorkbook.Close True
End Sub