Copying values from one sheet to another

I am trying to copy values from one sheet to another using loop with two conditions and it is very slow. Removing conditions from code doesn't have any effect on the speed of the execution.
I already have sample sheet where everything is done with functions (if/match/index...) but I would like to remove all functions from this workbook.

Here is the code :

Option Explicit
Private Sub AnalitSample()
    Dim WSS As Worksheet
    Set WSS = Sheets("Source")
    Dim WSD As Worksheet
    Set WSD = Sheets("Dest")

    Dim col As String
    col = "B"

    Dim rCell As Range
    Dim rRng As Range
    Set rRng = WSS.Range("B2:B4000")

    Dim i As Integer
    i = 2

    WSD.Range("B2:G4000").ClearContents

    For Each rCell In rRng.Cells
        If rCell.Value <> "" Then
            If Len(rCell.Value) > 3 Then
            WSD.Range(col & i).Value = rCell.Offset(0, 0).Value
            WSD.Range(col & i).Offset(0, 1).Value = rCell.Offset(0, 1).Value
            WSD.Range(col & i).Offset(0, 2).Value = rCell.Offset(0, 4).Value
            WSD.Range(col & i).Offset(0, 3).Value = rCell.Offset(0, 5).Value
            WSD.Range(col & i).Offset(0, 4).Value = rCell.Offset(0, 6).Value
            WSD.Range(col & i).Offset(0, 5).Value = rCell.Offset(0, 9).Value
            i = i + 1
            End If
            End If
        Next rCell
End Sub

I am asking for a few suggestions on how to speed up this kind of code (for each loop), that I was avoiding in the past because of the speed.

Lowest Hanging VBA Fruit:

Public Sub ()
    Application.ScreenUpdating = False
    Application.EnableEvents= False
    Application.Calculation= XlManual

    ...

    Code

    ...

    Application.ScreenUpdating = True
    Application.EnableEvents= True
    Application.Calculation= XlAutomatic
End Sub

Every time you access the worksheet, events trigger, formulas recalculate and Excel re-draws the screen.

You're accessing the worksheet 4,000 times.

Turning those options off will make your code inordinately faster. Just make sure they get reset back to normal at the end.

Superfluous Logic

If rCell.Value <> "" Then
    If Len(rCell.Value) > 3 Then

If Len(value) > 0 then, by definition, value is not an empty string. So you can just drop rCell.Value <> "".

Use row/column numbers. not Strings and offsets.

This is more of a good practice thing. Get in the habit of using Cells(Row, Column) instead of Range("B" & number).

Like so:

Dim finalRow As Long
Dim iRow As Long
Const TARGET_COL As Long = 2
Dim cellText As String

For iRow = 2 To finalRow

    cellText = WSS.Cells(iRow, TARGET_COL).Text

    If Len(cellText) > 3 Then
        '/ Do Stuff
    End If

Next iRow

StackExchange Code Review Q#132201, answer score: 15