تعديل مكرو الترحيل

Option Explicit

Sub From_Fatura_ALL()

Dim F As Worksheet

Dim Sw As Worksheet

Dim FRg As Range, Srg As Range

Dim Fix_Rg As Range

Dim Rf%, Cf%, Max_Row%

Dim x%, Y%



Set F = Sheets("فاتوره")

F.Protect UserInterfaceOnly:=True



Rf = F.Cells(Rows.Count, 5).End(3).Row

If Rf = 4 Then Exit Sub

Cf = 15

Set FRg = F.Range("C7").Resize(Rf - 6, Cf)



Set Fix_Rg = FRg.SpecialCells(xlCellTypeConstants)



x = Fix_Rg.Rows.Count: Y = FRg.Columns.Count



If F.Range("l1") = vbNullString Then Exit Sub

Set Sw = Sheets(F.Range("l1").Value)

Max_Row = Sw.Cells(Rows.Count, "E").End(3).Row + 1

If Max_Row < 8 Then Max_Row = 8





Sw.Range("C" & Max_Row).Resize(x, Y).Value = _

FRg.Value

    With Sw.Range("B" & Max_Row).Resize(x, Y + 1)

     .Borders.LineStyle = 1

     .Font.Size = 14

     .Font.Bold = True

     .InsertIndent 1

     .Cells(1, 1).Resize(x).Value = _

      Evaluate("row(1:" & x & ")")

     .Interior.ColorIndex = 35

    End With

         

          'Use This line to delete cells

          'That NoT contains Formula

       ''''''''''''''''''''''''''''''''''''''

         'Fix_Rg.ClearContents

       ''''''''''''''''''''''''''''''''''''''''

    Set Sw = Nothing: Set F = Nothing

    Set FRg = Nothing

    Set Srg = Nothing

    Set Fix_Rg = Nothing

End Sub