how make this code is short?

[Alaa mg]

hello
is there any way to make this code is short ?

Private Sub CommandButton1_Click()
Application.ScreenUpdating = False
Application.Calculation = xlManual
Application.EnableEvents = False
Dim ws As Worksheet: Set ws = Sheets("main")
Dim sr As Worksheet: Set sr= Sheets("records")
Dim i As Integer, x As Integer, k As Integer, lr As Integer, m As Integer
 'sh.Range("A10 :S20 ,B20 :L40").ClearContents
 lr = ws.Range("b" & Rows.count).End(xlUp).Row
 i = 8: k = 1: m = 2: z = 10
For x = 5 To lr
If  sr.Cells(4, 33).Value = ws.Cells(x, 20).Value And sr.Cells(6, 33).Value = ws.Cells(x, 16).Value Then
sr.Cells(i, 6).Value = ws.Cells(x, 40).Value
sr.Cells(i, 7).Value = ws.Cells(x, 28).Value
sr.Cells(i, 8).Value = ws.Cells(x, 29).Value
sr.Cells(i, 9).Value = ws.Cells(x, 30).Value
sr.Cells(i, 10).Value = ws.Cells(x, 31).Value
sr.Cells(i, 11).Value = ws.Cells(x, 32).Value
sr.Cells(i, 12).Value = ws.Cells(x, 33).Value
sr.Cells(i, 13).Value = ws.Cells(x, 34).Value
sr.Cells(i, 14).Value = ws.Cells(x, 35).Value
sr.Cells(i, 15).Value = ws.Cells(x, 36).Value
sr.Cells(i, 16).Value = ws.Cells(x, 37).Value
sr.Cells(i, 17).Value = ws.Cells(x, 38).Value
sr.Cells(i, 18).Value = ws.Cells(x, 39).Value
sr.Cells(i, 19).Value = ws.Cells(x, 3).Value
sr.Cells(i, 20).Value = ws.Cells(x, 4).Value
sr.Cells(i, 21).Value = ws.Cells(x, 5).Value
sr.Cells(i, 22).Value = ws.Cells(x, 6).Value
sr.Cells(i, 23).Value = ws.Cells(x, 14).Value
sr.Cells(i, 24).Value = ws.Cells(x, 13).Value
sr.Cells(i, 26).Value = ws.Cells(x, 12).Value
sr.Cells(i, 27).Value = ws.Cells(x, 7).Value
sr.Cells(i, 28).Value = ws.Cells(x, 8).Value
sr.Cells(i, 29).Value = ws.Cells(x, 9).Value
sr.Cells(i, 30).Value = ws.Cells(x, 11).Value
sr.Cells(i, 31).Value = "system"
i = i + 1
If i + 1 > z Then
i = k
i = m + k
k = 1 + k
m = m + 2
z = z + 2
End If
End If
Next x
Application.ScreenUpdating = True
Application.Calculation = xlAutomatic
Application.EnableEvents = True
MsgBox "done"

End Sub

 

[Peter_SSs]

I'm not sure what i, k, m and z are supposed to be doing, but I have just replace all of this ..

sr.Cells(i, 6).Value = ws.Cells(x, 40).Value
sr.Cells(i, 7).Value = ws.Cells(x, 28).Value
sr.Cells(i, 8).Value = ws.Cells(x, 29).Value
sr.Cells(i, 9).Value = ws.Cells(x, 30).Value
sr.Cells(i, 10).Value = ws.Cells(x, 31).Value
sr.Cells(i, 11).Value = ws.Cells(x, 32).Value
sr.Cells(i, 12).Value = ws.Cells(x, 33).Value
sr.Cells(i, 13).Value = ws.Cells(x, 34).Value
sr.Cells(i, 14).Value = ws.Cells(x, 35).Value
sr.Cells(i, 15).Value = ws.Cells(x, 36).Value
sr.Cells(i, 16).Value = ws.Cells(x, 37).Value
sr.Cells(i, 17).Value = ws.Cells(x, 38).Value
sr.Cells(i, 18).Value = ws.Cells(x, 39).Value
sr.Cells(i, 19).Value = ws.Cells(x, 3).Value
sr.Cells(i, 20).Value = ws.Cells(x, 4).Value
sr.Cells(i, 21).Value = ws.Cells(x, 5).Value
sr.Cells(i, 22).Value = ws.Cells(x, 6).Value
sr.Cells(i, 23).Value = ws.Cells(x, 14).Value
sr.Cells(i, 24).Value = ws.Cells(x, 13).Value
sr.Cells(i, 26).Value = ws.Cells(x, 12).Value
sr.Cells(i, 27).Value = ws.Cells(x, 7).Value
sr.Cells(i, 28).Value = ws.Cells(x, 8).Value
sr.Cells(i, 29).Value = ws.Cells(x, 9).Value
sr.Cells(i, 30).Value = ws.Cells(x, 11).Value

.. with a single line

Private Sub CommandButton1_Click()
  Application.ScreenUpdating = False
  Application.Calculation = xlManual
  Application.EnableEvents = False
  Dim ws As Worksheet: Set ws = Sheets("main")
  Dim sr As Worksheet: Set sr = Sheets("records")
  Dim i As Long, x As Long, k As Long, lr As Long, m As Long, z As Long
  
  lr = ws.Range("b" & Rows.Count).End(xlUp).Row
  i = 8: k = 1: m = 2: z = 10
  For x = 5 To lr
    If sr.Cells(4, 33).Value = ws.Cells(x, 20).Value And sr.Cells(6, 33).Value = ws.Cells(x, 16).Value Then
      sr.Cells(i, 6).Resize(, 25).Value = Application.Index(ws.Cells, x, Array(40, 28, 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, 39, 3, 4, 5, 6, 14, 13, 1000, 12, 7, 8, 9, 11))
      sr.Cells(i, 31).Value = "system"
      i = i + 1
      If i + 1 > z Then
        i = k
        i = m + k
        k = 1 + k
        m = m + 2
        z = z + 2
      End If
    End If
  Next x
  Application.ScreenUpdating = True
  Application.Calculation = xlAutomatic
  Application.EnableEvents = True
  MsgBox "done"

End Sub

 

[Alaa mg]

sr.Cells(i, 6).Resize(, 25).Value = Application.Index(ws.Cells, x, Array(40, 28, 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, 39, 3, 4, 5, 6, 14, 13, 1000, 12, 7, 8, 9, 11))

this idea is exactly what I want . this is better
thanks so much

 

[Peter_SSs]

You're welcome. Glad it helped. Thanks for the follow-up.