Copy cells in col. B, D and F if there is contents in cells in col. D

I am a "novice" in the field of vba and need assistance with code for the following task.
Thank you in advance for any valuable replies.

I have already made the code below and it works as I expect. It copies all cells in three columns, concatenates with various word strings, copies that and places the result in the clipboard.
A msg box appears in order to not clear the contents of the clipboard.
I then paste the contents of the clipboard into a word document. Which then pulls autotext/building blocks based on the pasted text string, in fact only the part that is derived from col. B

However I have changed other procedures in this WB which serves for a better experience with the autotext in word.

TASK
I need to only copy cells of col. A, D and F if there is contents in col. D - please refer to the attached image for visual reference.
The concatenation procedure shall remain as is.



Exisitng code that is attached to the button "Copy item no."

Sub CopyPosItemNumber()


Application.ScreenUpdating = False


'Unhide sheet
Sheets("Concat").Visible = True


'Unprotects sheet


Sheets("Commercial Calculation").Select
Sheets("Commercial Calculation").Unprotect Password:=3095
Sheets("Concat").Select
Sheets("Concat").Unprotect Password:=3095




Sheets("Concat").Range("A:F").ClearContents






'copies amount pieces number and paste to column B
Sheets("Commercial Calculation").Select
ActiveSheet.Range("F11", ActiveSheet.Range("F11").End(xlDown)).Select
Selection.Copy
Sheets("Concat").Range("B1").PasteSpecial Paste:=xlPasteValues


'copies item number and paste to column C
Sheets("Commercial Calculation").Select
ActiveSheet.Range("B11", ActiveSheet.Range("B11").End(xlDown)).Select
Selection.Copy
Sheets("Concat").Range("C1").PasteSpecial Paste:=xlPasteValues


'copies position number and paste to column A IMPORTANT because this is the last pasted objects this column
'is selected and that is why it is possible to insert Pos to these values you could also just selcte that column before
'starting the Pos paste runtime
Sheets("Commercial Calculation").Select
ActiveSheet.Range("D11", ActiveSheet.Range("D11").End(xlDown)).Select
Selection.Copy
Sheets("Concat").Range("A1").PasteSpecial Paste:=xlPasteValues




Sheets("Concat").Select


Dim IngLastRow As Long
'Uses Column A to set the IngLastRow variable (find last row) change if required.
IngLastRow = Cells(Rows.Count, "A").End(xlUp).Row


'Inserts Pos before contents of A
Dim a As Range
For Each a In Selection
If a.Value <> "" Then a.Value = "Pos " & a.Value
Next


'Concatenates B amount and C item no and inserts a blank space, a dash and a blank space after Pos places result in colum D
Range("D1:D" & IngLastRow).Formula = "=B1 & "" "" & C1"


'Concatenate A pos no and D amount and item and inserts a blank space, a dash and a blank space after Pos places result in colum D
Range("E1:E" & IngLastRow).Formula = "=A1 & "" - "" & D1"




Dim i As Long
Dim sht As Worksheet
Dim LastRow As Long
Dim str As String
str = ""
Set sht = Sheets("Concat")
LastRow = sht.Cells(sht.Rows.Count, "E").End(xlUp).Row


'takes all rows i column E and places that in cell F1 with carriage return i is the string which is the text in cells C
For i = 1 To LastRow
str = str + Cells(i, 5).Value & vbCrLf
Next i
Sheets("Concat").Range("F1").Value = str


'Copies contents of cell D1 to clipboard
Sheets("Concat").Select
ActiveSheet.Range("F1").Copy


Sheets("Commercial Calculation").Select


MsgBox "Please DO NOT close this message" & vbNewLine & "Before you have pasted contents to Word", vbOKOnly + vbInformation, "Paste to Word"


Sheets("Commercial Calculation").Protect Password:=3095


'Hide sheet
Sheets("Concat").Visible = False


Application.ScreenUpdating = True




End Sub

Trying to post the picture