Combine multiple macros into one [VBA]

[Martin_H]

Hi,

would it be possible to combine all the code below into a one macro?

Thank you for help.

Sub Copy_One()
Dim WS As Worksheet
Dim r As Range
Dim i As Long
i = 1
For Each WS In ActiveWorkbook.Worksheets
If WS.Name <> "SAP" And WS.Name <> "PLAN" And WS.Name <> "SUM" And WS.Name <> "TACHO" Then
Worksheets("TACHO").Range("J" & i & ":J" & i).Value = WS.Range("T128").Value
i = i + 1
End If
Next WS
End Sub


Sub Copy_Two()
Dim WS As Worksheet
Dim r As Range
Dim i As Long
i = 1
For Each WS In ActiveWorkbook.Worksheets
If WS.Name <> "SAP" And WS.Name <> "PLAN" And WS.Name <> "SUM" And WS.Name <> "TACHO" Then
Worksheets("TACHO").Range("M" & i & ":M" & i).Value = WS.Range("AO128").Value
i = i + 1
End If
Next WS
End Sub


Sub Copy_Three()
Dim WS As Worksheet
Dim r As Range
Dim i As Long
i = 1
For Each WS In ActiveWorkbook.Worksheets
If WS.Name <> "SAP" And WS.Name <> "PLAN" And WS.Name <> "SUM" And WS.Name <> "TACHO" Then
Worksheets("TACHO").Range("N" & i & ":N" & i).Value = WS.Range("AZ128").Value
i = i + 1
End If
Next WS
End Sub


Sub Copy_Four()
Dim WS As Worksheet
Dim r As Range
Dim i As Long
i = 1
For Each WS In ActiveWorkbook.Worksheets
If WS.Name <> "SAP" And WS.Name <> "PLAN" And WS.Name <> "SUM" And WS.Name <> "TACHO" Then
Worksheets("TACHO").Range("K" & i & ":K" & i).Value = WS.Range("AL128").Value
i = i + 1
End If
Next WS
End Sub


Sub Copy_Five()
Dim WS As Worksheet
Dim r As Range
Dim i As Long
i = 1
For Each WS In ActiveWorkbook.Worksheets
If WS.Name <> "SAP" And WS.Name <> "PLAN" And WS.Name <> "SUM" And WS.Name <> "TACHO" Then
Worksheets("TACHO").Range("i" & i & ":i" & i).Value = WS.Range("B2").Value
i = i + 1
End If
Next WS
End Sub

 

[Fluff]

You can do that like

Sub MartinH()
   Dim WS As Worksheet
   Dim i As Long
   i = 1
   For Each WS In ActiveWorkbook.Worksheets
      If WS.Name <> "SAP" And WS.Name <> "PLAN" And WS.Name <> "SUM" And WS.Name <> "TACHO" Then
         With Worksheets("TACHO")
            .Range("J" & i).Value = WS.Range("T128").Value
            .Range("M" & i).Value = WS.Range("AO128").Value
            .Range("N" & i).Value = WS.Range("AZ128").Value
         End With
         i = i + 1
      End If
   Next WS
End Sub

 

[Martin_H]

Much much better

Thanks for the lightning fast response Fluff!

 

[Fluff]

You're welcome & thanks for the feedback.

 

[johnnyL]

What happened to range K & I ?

 

[Fluff]

Nothing.