'scalaj z Arkusz1 do Arkusz2
Sub scalaj()
  Dim rgS As Range, rgD As Range
  Dim s As String, wpis As String

  On Error GoTo Error_scalaj
  '1-sza komórka źródłowa

  Set rgS = Worksheets("Arkusz1").Range("A1")

  '1-sza komórka docelowa
  Set rgD = Worksheets("Arkusz2").Range("A1")

  'zawartość 1-szej i 2-giej komórki
  wpis = rgS
  Set rgS = rgS.Offset(1, 0)
  s = rgS

  'powtarzaj aż napotkasz pustą komórkę
  Do
    'zapisz jeśli 'pk' w komórce
    If InStr(1, s, "pk") > 0 Then
      'zapisz
      rgD = wpis
      'kolejny wiersz wpisu
      Set rgD = rgD.Offset(1, 0)
      '1-sza częśc wpisu zawierająca 'pk'
      wpis = s
    Else
      'dodaj kolejny wyraz
      wpis = wpis & " " & s
    End If

    Set rgS = rgS.Offset(1, 0)
    s = rgS

  Loop While s <> ""

  'zapis ostatniego wiersza
  rgD = wpis

Exit_scalaj:
  On Error Resume Next

  Exit Sub

Error_scalaj:
  MsgBox "Error: " & Err.Number & " ( " & Err.Description & " )" & vbCrLf & _
      vbCrLf & "Procedure: scalaj", vbExclamation
  Resume Exit_scalaj
End Sub