Forum Discussion

wass024's avatar
wass024
Copper Contributor
Feb 08, 2022

Need to index every fifth column to a single column

Hi, I have four columns of data types that will repeat with a space between. They will all need to put into single columns on a different sheet, so column A should have column F under it, and column ...
excel
HansVogelaar's avatar
HansVogelaar
MVP
Feb 08, 2022

wass024 

Here is a macro you can run:

Sub MoveData()
    Dim ws As Worksheet
    Dim wt As Worksheet
    Dim r As Long
    Dim m As Long
    Dim c As Long
    Dim n As Long
    Application.ScreenUpdating = False
    Set ws = ActiveSheet
    Set wt = Worksheets.Add(After:=ws)
    m = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
    n = ws.Cells(1, Columns.Count).End(xlToLeft).Column
    r = 1
    For c = 1 To n Step 5
        wt.Cells(r, 1).Resize(m, 4).Value = ws.Cells(1, c).Resize(m, 4).Value
        r = r + m
    Next c
    Application.ScreenUpdating = True
End Sub
  • wass024's avatar
    wass024
    Copper Contributor
    Feb 09, 2022

    HansVogelaar 

    Amazing!!!! Thank you so much.  How can I get the macro to overwrite the worksheet each time I update it instead of creating a new worksheet?

     

    Thanks.

    • HansVogelaar's avatar
      HansVogelaar
      MVP
      Feb 09, 2022

      wass024 

      The following version will write the data to a sheet named Result.

      If it does not exist yet, it will be created.

      If it already exists, it will be cleared first.

      You can change the name in the code.

      Sub MoveData()
    ' Name for the sheet with the result
    ' Change to your own preference
    Const TargetName = "Result"
    Dim ws As Worksheet
    Dim wt As Worksheet
    Dim r As Long
    Dim m As Long
    Dim c As Long
    Dim n As Long
    Application.ScreenUpdating = False
    Set ws = ActiveSheet
    On Error Resume Next
    Set wt = Worksheets(TargetName)
    On Error GoTo 0
    If wt Is Nothing Then
        Set wt = Worksheets.Add(After:=ws)
        wt.Name = TargetName
    Else
        wt.UsedRange.Clear
    End If
    m = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
    n = ws.Cells(1, Columns.Count).End(xlToLeft).Column
    r = 1
    For c = 1 To n Step 5
        wt.Cells(r, 1).Resize(m, 4).Value = ws.Cells(1, c).Resize(m, 4).Value
        r = r + m
    Next c
    Application.ScreenUpdating = True
End Sub

Resources