Copy data from one sheet to another, provided

[sofas]

Hello. I tried to create this code, but it is very slow. I do not know why. Can you help me to solve this problem or replace it with another one that does the same task?

Sub data()

Set WS = Worksheets("SHEET1")
Set WS1 = Worksheets("SHEET2")
Application.ScreenUpdating = False



On Error Resume Next
If WS.Range("D5").Value = "" Then: Exit Sub


Dim Lr As Long
Dim Mh As Long
Dim iCont As Integer
Dim r As Integer
Dim c As Integer
Dim ii As Double

ii = WS.Range("D5").Value

With WS1
    Lr = .Cells(.Rows.Count, "b").End(xlUp).Row + 1
    Mh = WorksheetFunction.Match(ii, .Range("D5:D" & Lr), 0) + 8
    iCont = WorksheetFunction.CountIf(.Range("D5:D" & Lr), ii)
End With
X = 3
For c = 2 To 2
WS.Cells(X, 4) = WS1.Cells(Mh, c).Value
WS.Cells(X + 1, 4) = WS1.Cells(Mh, c + 1).Value
WS.Cells(X + 3, 4) = WS1.Cells(Mh, c + 3).Value

WS.Cells(X + 1, 6) = WS1.Cells(Mh, c + 15).Value
WS.Cells(X + 3, 6) = WS1.Cells(Mh, c + 17).Value
WS.Cells(X + 2, 6) = WS1.Cells(Mh, c + 16).Value
WS.Cells(3, 6) = WS1.Cells(Mh, c + 14).Value

WS.Cells(3, 2) = WS1.Cells(Mh, c + 10).Value
WS.Cells(4, 2) = WS1.Cells(Mh, c + 11).Value
WS.Cells(5, 2) = WS1.Cells(Mh, c + 12).Value
WS.Cells(6, 2) = WS1.Cells(Mh, c + 13).Value

X = X + 1
Next
Application.ScreenUpdating = False
For r = 1 To iCont
       For c = 1 To 5
      WS.Cells(r + 8, c + 1) = WS1.Range("F" & Mh).Cells(r, c).Value
 Next
  
 Next
Application.ScreenUpdating = True
End Sub

 

[sofas]

Hello. I tried to create this code, but it is very slow. I do not know why. Can you help me to solve this problem or replace it with another one that does the same task?

Sub data()

Set WS = Worksheets("SHEET1")
Set WS1 = Worksheets("SHEET2")
Application.ScreenUpdating = False



On Error Resume Next
If WS.Range("D5").Value = "" Then: Exit Sub


Dim Lr As Long
Dim Mh As Long
Dim iCont As Integer
Dim r As Integer
Dim c As Integer
Dim ii As Double

ii = WS.Range("D5").Value

With WS1
    Lr = .Cells(.Rows.Count, "b").End(xlUp).Row + 1
    Mh = WorksheetFunction.Match(ii, .Range("D5:D" & Lr), 0) + 8
    iCont = WorksheetFunction.CountIf(.Range("D5:D" & Lr), ii)
End With
X = 3
For c = 2 To 2
WS.Cells(X, 4) = WS1.Cells(Mh, c).Value
WS.Cells(X + 1, 4) = WS1.Cells(Mh, c + 1).Value
WS.Cells(X + 3, 4) = WS1.Cells(Mh, c + 3).Value

WS.Cells(X + 1, 6) = WS1.Cells(Mh, c + 15).Value
WS.Cells(X + 3, 6) = WS1.Cells(Mh, c + 17).Value
WS.Cells(X + 2, 6) = WS1.Cells(Mh, c + 16).Value
WS.Cells(3, 6) = WS1.Cells(Mh, c + 14).Value

WS.Cells(3, 2) = WS1.Cells(Mh, c + 10).Value
WS.Cells(4, 2) = WS1.Cells(Mh, c + 11).Value
WS.Cells(5, 2) = WS1.Cells(Mh, c + 12).Value
WS.Cells(6, 2) = WS1.Cells(Mh, c + 13).Value

X = X + 1
Next
Application.ScreenUpdating = False
For r = 1 To iCont
       For c = 1 To 5
      WS.Cells(r + 8, c + 1) = WS1.Range("F" & Mh).Cells(r, c).Value
 Next
 
 Next
Application.ScreenUpdating = True
End Sub

Hello.Is there a solution to my problem