aşağıdaki gibi düzenleyip dener misiniz?

Public Sub berat()

On Error Resume Next

Dim MyCell As Range, MyRange As Range, deger1 As Range, deger2 As Range, deger3 As Range

Dim intSatir As Integer



Set MyRange = Sheets("Sayfa2").Range("A2")

Set MyRange = Range(MyRange, MyRange.End(xlDown))

Set deger1 = Sheets("Sayfa2").Range("B2")

Set deger1 = Range(deger1, deger1.End(xlDown))

Set deger2 = Sheets("Sayfa2").Range("C2")

Set deger2 = Range(deger2, deger2.End(xlDown))

Set deger3 = Sheets("Sayfa2").Range("D2")

Set deger3 = Range(deger3, deger3.End(xlDown))



For Each MyCell In MyRange



Sheets("Sayfa1").Copy After:=Sheets(Sheets.Count)



intSatir = MyCell.Row ' <== eklenen

Sheets(Sheets.Count).Name = MyCell.Value

Sheets(MyCell.Value).ClearContents ' <== eklenen

Sheets(MyCell.Value).Range("b3").Value = Sheets("Sayfa2").Range("B" & intSatir).Value ' <== değişen

Sheets(MyCell.Value).Range("f6").Value = Sheets("Sayfa2").Range("C" & intSatir).Value

Sheets(MyCell.Value).Range("g4").Value = Sheets("Sayfa2").Range("D" & intSatir).Value

Next MyCell





End Sub