• DİKKAT !

    Forum içeriğine ve tüm hizmetlerimize erişim sağlamak için foruma kayıt olmalı ya da giriş yapmalısınız. Foruma üye olmak Dosya Yükleme tamamen ücretsizdir.

Çözüldü sayfayı dışarı aktarma değer olarak kaydetme

Bu konu çözüldü olarak işaretlenmiştir. Çözülmediğini düşünüyorsanız konuyu rapor edebilirsiniz.
Durum
Konu Çözümlendiği İçin Kapatılmıştır.

ilkay94

Yeni Üye
Katılım
27 Nis 2022
Mesajlar
139
Aldığı beğeni
9
Excel V
Office 2016 TR
Konu Sahibi
Merhaba Arkadaşlar,

Zafer ve Adnan hocalarımın yazdıkları kodları son bir şekilde daha değiştirmek istiyorum,

Aşşağıda ki kodu aynı pdf verirken kayıt yeri sorup seçtiğim yere aynı hücrelerden verileri alıp isimlendirip excel olarak kaydetsin istiyorum,

Ancak kaydedeceği dışarı aktaracağı excel de formül olmayacak yani formülleri ayrı kaydederken kaydetmeyecek

Eski formatlarda versede olur hepsini metin olarak kaydederek versede olur,

Yardım rica ediyorum,

On Error Resume Next

If TextBox1.Value = "" Then
MsgBox "Öncelikle Bir Ana Reçete Seçiniz", vbCritical, "İPTAL"
Exit Sub
End If

Dim s1 As Worksheet, s2 As Worksheet
Dim BUL As Range, satır, son As Long
Set s1 = Sheets("ALTKATÜRETİMLER")
Set s2 = Sheets("YAZDIR")
satır = 0
s2.Range("A6:I" & rows.count).Clear
s2.PageSetup.PrintArea = ""
Application.ScreenUpdating = False

s2.Select
s1son = s1.Range("A" & rows.count).End(3).row
For i = 2 To s1son
If s1.Range("A" & i) = TextBox1.Text Then
satır = satır + 1
s1.Range("C" & i & ": K" & i).Copy s2.Cells(satır + 5, 1)

End If
Next i


If satır = 0 Then
MsgBox "Reçeteye ait kimyasal kaydı yok.", vbCritical, "UYARI"
Application.ScreenUpdating = True
Exit Sub
End If
son = s2.Cells(rows.count, 3).End(3).row


With s2.Range("A6:I" & son)


Range("A6:I" & son).Select
Selection.NumberFormat = "@"

.Borders.LineStyle = 1
.Borders.LineStyle = xlContinuous
End With
altkatSat = Sayfa2.Cells(rows.count, 1).End(xlUp).row
altkatsatir = Application.WorksheetFunction.Match(CLng(TextBox1.Text), Sayfa2.Range("A1:A" & altkatSat))

s2.Range("B1") = Sayfa2.Cells(altkatsatir, 4)
s2.Range("B2") = Sayfa2.Cells(altkatsatir, 6)
s2.Range("B3") = Sayfa2.Cells(altkatsatir, 11)
s2.Range("B4") = Sayfa2.Cells(altkatsatir, 3)
s2.Range("D1") = Sayfa2.Cells(altkatsatir, 2)
s2.Range("D2") = Sayfa2.Cells(altkatsatir, 9)
s2.Range("D3") = Sayfa2.Cells(altkatsatir, 10)
s2.Range("D4") = Sayfa2.Cells(altkatsatir, 7)
s2.Range("G2") = Sayfa2.Cells(altkatsatir, 12)




s2.columns("A:I").EntireColumn.AutoFit

's2.Range("A" & son + 5) = "Bu bir vidala boyama proses reçetesidir. "
's2.Range("A" & son + 5).Font.Size = 24
's2.Range("A" & son + 5).Font.Color = vbBlue 'Yazı rengi kırmızı istemezsen bunu silebilirsin


s2.Range("A6").Select

On Error GoTo 0


Dim sFolder As String

With Application.FileDialog(msoFileDialogSaveAs)
.Title = "PDF olarak kaydet"
.InitialFileName = ThisWorkbook.Path & "\" & s2.[B1] & " " & s2.[B4] & ".pdf"

PDFsatir = 0
For i = 1 To .Filters.count
If UCase(.Filters(i).Description) = "PDF" Then PDFsatir = i
Next
.FilterIndex = PDFsatir
If .Show Then
s2.Range("A1:I" & son + 5).ExportAsFixedFormat Type:=xlTypePDF, Filename:=.SelectedItems(1), OpenAfterPublish:=False 'true olursa pdf acilir
'MsgBox .SelectedItems(1) & vbNewLine & "Olarak Kaydedildi", vbInformation PDF kaydedildi mesajı verir
Else
MsgBox "Vazgecildi", vbExclamation
End If
End With




Application.CutCopyMode = False
Application.ScreenUpdating = True
son = Empty

bitir:


Worksheets("ALTKATÜRETİMLER").Select

End Sub
 
If .Show Then satırının altına ekleyiniz.
HTML:
Kod:
İçeriği görebilmek için Giriş yap ya da Üye ol.
 
Konu Sahibi
If .Show Then satırının altına ekleyiniz.
HTML:
Kod:
İçeriği görebilmek için Giriş yap ya da Üye ol.
Merhaba Hocam,

İyi akşamlar,

Dediğiniz gibi yaptım ancak seçtiğim klasöre atmıyor sabit hep dosyanın kayıtlı olduğu yere atıyor;

Private Sub REÇETEEXCELAL_Click()
On Error Resume Next

If TextBox1.Value = "" Then
MsgBox "Öncelikle Bir Ana Reçete Seçiniz", vbCritical, "İPTAL"
Exit Sub
End If

Dim s1 As Worksheet, s2 As Worksheet
Dim BUL As Range, satır, son As Long
Set s1 = Sheets("ALTKATÜRETİMLER")
Set s2 = Sheets("YAZDIR")
satır = 0
s2.Range("A6:I" & rows.count).Clear
s2.PageSetup.PrintArea = ""
Application.ScreenUpdating = False

s2.Select
s1son = s1.Range("A" & rows.count).End(3).row
For i = 2 To s1son
If s1.Range("A" & i) = TextBox1.Text Then
satır = satır + 1
s1.Range("C" & i & ": K" & i).Copy s2.Cells(satır + 5, 1)

End If
Next i


If satır = 0 Then
MsgBox "Reçeteye ait kimyasal kaydı yok.", vbCritical, "UYARI"
Application.ScreenUpdating = True
Exit Sub
End If
son = s2.Cells(rows.count, 3).End(3).row


With s2.Range("A6:I" & son)


Range("A6:I" & son).Select
Selection.NumberFormat = "@"

.Borders.LineStyle = 1
.Borders.LineStyle = xlContinuous
End With
altkatSat = Sayfa2.Cells(rows.count, 1).End(xlUp).row
altkatsatir = Application.WorksheetFunction.Match(CLng(TextBox1.Text), Sayfa2.Range("A1:A" & altkatSat))

s2.Range("B1") = Sayfa2.Cells(altkatsatir, 4)
s2.Range("B2") = Sayfa2.Cells(altkatsatir, 6)
s2.Range("B3") = Sayfa2.Cells(altkatsatir, 11)
s2.Range("B4") = Sayfa2.Cells(altkatsatir, 3)
s2.Range("D1") = Sayfa2.Cells(altkatsatir, 2)
s2.Range("D2") = Sayfa2.Cells(altkatsatir, 9)
s2.Range("D3") = Sayfa2.Cells(altkatsatir, 10)
s2.Range("D4") = Sayfa2.Cells(altkatsatir, 7)
s2.Range("G2") = Sayfa2.Cells(altkatsatir, 12)




s2.columns("A:I").EntireColumn.AutoFit

's2.Range("A" & son + 5) = "Bu bir vidala boyama proses reçetesidir. "
's2.Range("A" & son + 5).Font.Size = 24
's2.Range("A" & son + 5).Font.Color = vbBlue 'Yazı rengi kırmızı istemezsen bunu silebilirsin


s2.Range("A6").Select

On Error GoTo 0


Dim sFolder As String

With Application.FileDialog(msoFileDialogSaveAs)
.Title = "EXCEL olarak kaydet"
.InitialFileName = ThisWorkbook.Path & "\" & s2.[B1] & " " & s2.[B4] & ".pdf"

PDFsatir = 0
For i = 1 To .Filters.count
If UCase(.Filters(i).Description) = "EXCEL" Then PDFsatir = i
Next
.FilterIndex = PDFsatir
If .Show Then
s2.Copy
Range("A1:I" & son + 5).Value = Range("A1:I" & son + 5).Value
ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\" & s2.[B1] & " " & s2.[B4] & ".xlsx", FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
ActiveWorkbook.Close
Else
MsgBox "Vazgecildi", vbExclamation
End If
End With




Application.CutCopyMode = False
Application.ScreenUpdating = True
son = Empty

bitir:


Worksheets("ALTKATÜRETİMLER").Select
 
Konu uçmuş gitmiş örnek dosya ekleyerek yeni konu açın abey.
 
Durum
Konu Çözümlendiği İçin Kapatılmıştır.
Geri
Üst