Merhaba abey.
Bu kodun hücre biçimleriyle alakası yok.
Başka koddandır belki.
Zafer Hocam,
USD hesaplamasını doğru yapıyor,
Euro yapmıyor 0 getiriyor,
Usd gibi işlem yapıp sonrasında H5 hücresi ile sabit çarpması gerekiyor orada parite var,
Hizalamayı da makro kaydet ile yaptım ancak çok uzun kodlama oldu,
Private Sub MALİYETYAZDIR_Click()
On Error Resume Next
PARİTEKAYIT.Show
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("MALİYET YAZDIR")
satır = 0
s2.Range("A7:L" & 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 & ": M" & i).Copy s2.Cells(satır + 6, 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:L" & son)
Range("A6:K" & 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)
With ThisWorkbook.Sheets("MALİYET YAZDIR")
For i = 7 To .Range("K" & rows.count).End(3).row
Select Case .Cells(i, "K").Value
Case "USD": .Cells(i, "L").Value = .Cells(i, "A").Value * .Cells(i, "j").Value
Case "EURO": .Cells(i, "L").Value = .Cells(i, "A").Value * .Cells(i, "J").Value * .Cells(5, "i").Value
End Select
Next
End With
Range("L7:L1000").Select
Selection.NumberFormat = "#,##0.0"
With Selection.Font
.Name = "Calibri"
.Size = 20
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ThemeColor = xlThemeColorLight1
.TintAndShade = 0
.ThemeFont = xlThemeFontMinor
End With
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Selection.Font.Bold = True
s2.columns("A:L").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("A7").Select
On Error GoTo 0
s2.PageSetup.PrintArea = "$A$1:$L$" & son + 5
msg = MsgBox("Yazdirma alani tamam. Çıktı almak istiyor musunuz?", vbInformation + vbYesNo)
If msg = vbYes Then
kacadet = InputBox("Kaç adet Çıktı Almak İstiyorsunuz?", "Çıktı Kopya Sayısı", "")
If kacadet = "" Then Exit Sub
s2.PrintOut 1, 1, preview:=False, Copies:=CInt(kacadet)
Else
MsgBox "Vazgeçildi", vbCritical, "İPTAL"
End If
Application.CutCopyMode = False
Application.ScreenUpdating = True
son = Empty
bitir:
Worksheets("ALTKATÜRETİMLER").Select
