Macro to move cells throughout spreadsheet

[Mel120585]

Hi everyone!

I hope someone can help, I am terrible at macros but would like to learn if possible!

I have a relatively large spreadsheet that I need to do two things to:

1) move every second cell in one row to the second row down in the previous column
2) delete every second column

I appreciate the second might be relatively easy to do but with over 12,000 columns of data it would be preferable to automate the process!

Please do let me know if this doesn't make sense and hope someone tasks pity on me

Thanks

Mel

 

[Fluff]

Hi & welcome to the board
Part 2 is easy
Part 1 Which rows/columns do you want this to work on & do you want to overwrite the data?

 

[Mel120585]

Hi & welcome to the board
Part 2 is easy
Part 1 Which rows/columns do you want this to work on & do you want to overwrite the data?

Hi Fluff,

Thank you for getting back to me! I thought an example might be easier so I have made up a table below.


[TABLE="class: grid, width: 500"]
<tbody>[TR]
[TD]Name[/TD]
[TD]25.5.2017[/TD]
[TD]Name[/TD]
[TD]26.4.2016[/TD]
[TD]Name[/TD]
[TD]14.5.2017[/TD]
[TD]Name[/TD]
[TD]16.7.2012[/TD]
[/TR]
[TR]
[TD]HR[/TD]
[TD]Exertion[/TD]
[TD]HR[/TD]
[TD]Exertion[/TD]
[TD]HR[/TD]
[TD]Exertion[/TD]
[TD]HR[/TD]
[TD]Exertion[/TD]
[/TR]
[TR]
[TD]110
[/TD]
[TD]0[/TD]
[TD]132[/TD]
[TD]0[/TD]
[TD]124[/TD]
[TD]0[/TD]
[TD]114[/TD]
[TD]0[/TD]
[/TR]
[TR]
[TD]111[/TD]
[TD]0[/TD]
[TD]135[/TD]
[TD]0[/TD]
[TD]128[/TD]
[TD]0[/TD]
[TD]110[/TD]
[TD]0[/TD]
[/TR]
[TR]
[TD]111[/TD]
[TD]0[/TD]
[TD]130[/TD]
[TD]0[/TD]
[TD]120[/TD]
[TD]0[/TD]
[TD]118[/TD]
[TD]0[/TD]
[/TR]
</tbody>[/TABLE]

What I would love is to be able to copy and past the date in every second column to where it says HR (overwriting HR) and then delete the column the date was originally in so above turns into:

[TABLE="class: grid, width: 500"]
<tbody>[TR]
[TD]Name[/TD]
[TD]Name[/TD]
[TD]Name[/TD]
[TD]Name[/TD]
[/TR]
[TR]
[TD]25.5.2017[/TD]
[TD]26.4.2016[/TD]
[TD]14.5.2017[/TD]
[TD]16.7.2012[/TD]
[/TR]
[TR]
[TD]110[/TD]
[TD]132[/TD]
[TD]124[/TD]
[TD]114[/TD]
[/TR]
[TR]
[TD]111[/TD]
[TD]135[/TD]
[TD]128[/TD]
[TD]110[/TD]
[/TR]
[TR]
[TD]111[/TD]
[TD]130[/TD]
[TD]120[/TD]
[TD]118[/TD]
[/TR]
</tbody>[/TABLE]

Glad number 2 is easy for some people!!

Many thanks,

Mel

 

[Fluff]

Try this on a copy of your data

Sub MoveCells_DelCol()
'Mel120585

    Dim UsdCols As Long
    Dim Cnt As Long
    
    For Cnt = 2 To Cells(1, Columns.Count).End(xlToLeft).Column Step 2
        Cells(2, Cnt - 1).Value = Cells(1, Cnt).Value
        Cells(1, Cnt).Value = ""
    Next Cnt
    Rows(1).SpecialCells(xlBlanks).EntireColumn.Delete
    
End Sub

 

[Mel120585]

Thank you Fluff! This works but only for one column of data whereas I would like it for every participant who currently has two columns each. Is there a way to repeat this process throughout by 4 spreadsheets with 3,000 plus columns each?

thanks

Mel

 

[Fluff]

Are the names in row1?
Is the number of columns the same for each sheet?, if so what is the last column?
When you say 4 spreadsheets, do you mean 4 sheets (ie all in the same workbook)? If so are there just the 4 sheets?

 

[Rick Rothstein]

Does this macro work for you...

Sub MoveCellsDeleteEveryOtherColumn()
  Dim Rng As Range
  Set Rng = Range("A1").CurrentRegion
  Rng.Rows(1).Offset(, 1).Copy Rng.Rows(2)
  Rng.Rows(2).Replace "Name", "", xlWhole
  Rng.Rows(2).SpecialCells(xlBlanks).EntireColumn.Delete
End Sub

Edit Note: I just saw your follow up message regarding 4 sheets... what are the sheet names?

 

[Rick Rothstein]

Does this macro work for you...

Sub MoveCellsDeleteEveryOtherColumn()
  Dim Rng As Range
  Set Rng = Range("A1").CurrentRegion
  Rng.Rows(1).Offset(, 1).Copy Rng.Rows(2)
  Rng.Rows(2).Replace "Name", "", xlWhole
  Rng.Rows(2).SpecialCells(xlBlanks).EntireColumn.Delete
End Sub

Edit Note: I just saw your follow up message regarding 4 sheets... what are the sheet names?

It just occurred to me that where you have Names, that is not a header, rather, individual and unique names will be located there. Given that, this is the macro by me that you should consider, not the one I posted above. You also said you wanted this code to apply to four sheets, but you did not give us the names of the sheets, so my code uses Sheet1, Sheet2, Sheet3 and Sheet4... change those names in the code to the actual names of your sheets.

Sub MoveCellsDeleteEveryOtherColumn()
  Dim WS As Variant
  For Each WS In Array("[COLOR="#FF0000"]Sheet1[/COLOR]", "[COLOR="#FF0000"]Sheet2[/COLOR]", "[COLOR="#FF0000"]Sheet3[/COLOR]", "[COLOR="#FF0000"]Sheet4[/COLOR]")
    With Sheets(WS).Range("A1").CurrentRegion.Rows(1)
      .Offset(, 1).Copy .Offset(1)
      .Replace "*.*.*", "", xlWhole
      .SpecialCells(xlBlanks).EntireColumn.Delete
    End With
  Next
End Sub

 

[Mel120585]

Are the names in row1?
Is the number of columns the same for each sheet?, if so what is the last column?
When you say 4 spreadsheets, do you mean 4 sheets (ie all in the same workbook)? If so are there just the 4 sheets?

Hi,

Unfortunately the number of columns is not uniform but as I only have four workbooks I can change that manually if that makes the coding easier? I can copy and paste the data into seperate worksheets within one workbook too if that is better?

thanks

Mel

 

[Rick Rothstein]

Unfortunately the number of columns is not uniform but as I only have four workbooks I can change that manually if that makes the coding easier? I can copy and paste the data into seperate worksheets within one workbook too if that is better?

Did you get to see Message #8 yet?