Makro Kodu:
Sub farklı2()
Dim YL As String, ÇLŞ As Variant, SYF As Long
Dim KTP As Workbook, KÇLŞ As String, KTP2 As Workbook
Dim S1 As Worksheet, KSYF As Long, S2 As Worksheet
Dim SÇLŞ As String
Application.ScreenUpdating = False
Set KTP = ActiveWorkbook
YL = ThisWorkbook.Path & "\"
SÇLŞ = ActiveSheet.Name
For SYF = 2 To KTP.Sheets.Count
Set S1 = KTP.Sheets(SYF)
If S1.Range("H1") <> Empty Then
S1.Select
ÇLŞ = ActiveCell.Address
Workbooks.Add
Set KTP2 = ActiveWorkbook
S1.Copy KTP2.Sheets(1)
For KSYF = KTP2.Sheets.Count To 2 Step -1
Application.DisplayAlerts = False
Sheets(KSYF).Delete
Application.DisplayAlerts = True
Next
Set S2 = KTP2.Sheets(1)
S2.Cells.Copy
S2.Range("A1").PasteSpecial xlPasteValues
Application.CutCopyMode = False
Range(ÇLŞ).Select
S2.Name = S1.Range("E1").Text
KTP2.saveas YL & S1.Range("H1").Text & ".xlsx", xlOpenXMLWorkbook
KTP2.Close
End If: Next
Sheets(SÇLŞ).Select
Application.ScreenUpdating = True
End Sub
yardımcı olan arkadaşlara şimdiden teşekkürler