Save As Every Workbook and Limit the Rows to 200

[PRIMA]

Dear All,

The code below is asking the file to select and save as, however, it will only save as once. In my case, I have 20,000 each worksheet and I want them to separately save as with different filename but it will only limit the rows to 200 each worksheet for every workbook or filename.

Say for Example:

The Header is in Row 1 & 2 = fixed

filename01
row 1+2 fix header
row 3 to 200 (from the original file)

filename02
row 1+2 fix header
row 201 to 398 (from the original file), but it should start from row 3

filename02
row 1+2 fix header
row 399 to 596 (from the original file), but it should start from row 3

until it will reach to the last row. Any ideas/suggestion please..

Sub SaveWB()
 
Dim strFile As String
Dim xlCalc As XlCalculation
Dim wb As Workbook, ws As Worksheet
Dim r As Range
With Application.FileDialog(msoFileDialogFilePicker)
    .Title = "Please select your file"
    .InitialFileName = Application.DefaultFilePath
    .AllowMultiSelect = False
    If .Show = -1 Then strFile = .SelectedItems(1) Else Exit Sub
End With
With Application
    xlCalc = .Calculation
    .Calculation = xlCalculationManual
    .ScreenUpdating = False
End With
Set wb = Workbooks.Open(strFile, False)
For Each ws In wb.Worksheets
    With ws
        Set r = Application.Intersect(.Range("201:" & .Rows.Count), .UsedRange)
        If Not r Is Nothing Then r.EntireRow.Clear
        Set r = Nothing
    End With
Next ws
With Application.FileDialog(msoFileDialogSaveAs)
    .Title = "Please choose filename to save as"
    .AllowMultiSelect = False
    .InitialFileName = wb.FullName
    If .Show = -1 Then .Execute
End With
wb.Close
 
End Sub

 

[PRIMA]

Can anybody help me please.. Thanks..

 

[PRIMA]

Guys, can you help me on this. Thank you..