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
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