VBA to sort columns

[alanlambden]

Hi All,

I have multiple tabs I need to merge. I have been able to write the code to merge the into data into one spreadsheet, but sometimes that columns aren't a match. Is there a way I can sweep some VBA code over my workbook and sort the columns depending on the title, ideally going through all the tabs in one run.

Say the tabs are labelled 'Tab1', 'tab2' 'tab3' .... 'tab50'

Here is the example .. Is there a way I can check each tab and identify

if column heading 'blue' exists, move this to columnC.
If column heading 'yellow' exists, move this to columnD and
if column heading 'red' exists, move this to columnE

and so on. I have about 9 columns I need to ensure are all in the same corresponding column.

Also some tabs are missing some of the headings, like 'red' might be missing so:

if column heading 'red' doesn't exist, ignore and move onto the next column and leave it blank.

This would get every column in the correct place, allowing me to run the macro to collate each tab into a master tab.

Thanks for your help with this.

 

[DanteAmor]

Try this

Change data in red for your information.
I assume that the titles are in row 1 and the data to be copied is from row 2 down.

Sub sort_columns()
  Dim sh As Worksheet, sh2 As Worksheet, lbls As Variant, cols As Variant
  Dim lr As Long, i As Long, lr2 As Long, f As Range
  '
  Application.ScreenUpdating = False
  Set sh2 = Sheets("[COLOR=#ff0000]Master[/COLOR]")
  lbls = Array("[COLOR=#ff0000]blue[/COLOR]", "[COLOR=#ff0000]yellow[/COLOR]", "[COLOR=#ff0000]red[/COLOR]")
  cols = Array("[COLOR=#ff0000]C[/COLOR]", "[COLOR=#ff0000]D[/COLOR]", "[COLOR=#ff0000]E[/COLOR]")
  For Each sh In Sheets
    Select Case True
      Case Left(sh.Name, 3) = "[COLOR=#ff0000]Tab[/COLOR]" Or sh.Name <> sh2.Name
        For i = 0 To UBound(lbls)
          Set f = sh.Rows([COLOR=#ff0000]1[/COLOR]).Find(lbls(i), , xlValues, xlWhole)
          If Not f Is Nothing Then
            lr = sh.Cells(Rows.Count, f.Column).End(xlUp).Row
            sh.Range(sh.Cells([COLOR=#ff0000]2[/COLOR], f.Column), sh.Cells(lr, f.Column)).Copy
            lr2 = sh2.Cells(Rows.Count, cols(i)).End(xlUp).Row + 1
            sh2.Cells(lr2, cols(i)).PasteSpecial xlPasteValues
          End If
        Next
    End Select
  Next
  Application.CutCopyMode = False
End Sub

 

[alanlambden]

Hi DanteAmor,

The data to be copied is the entire column, not just the second row onwards. I want the column headings and all its contents to be moved into a consistent position for every tab.

Thanks

 

[DanteAmor]

Just change 2 to 1 in this line

  sh.Range(sh.Cells(1, f.Column), sh.Cells(lr, f.Column)).Copy

Try and tell me.

 

[alanlambden]

I need a little bit more hand-holding with this one. I keep getting a runtime error. Here is your code with my data filled in. I have 90 tabs in my worksheet. Each one is named Planilha, Planilha (1), Planilha (2) ... Planilha (90). The name of my file is 'MyVBA". The ("VSP", "Temp", "GR", "N8", "N16", "N32", "N64", "Cond", "Velocity") are the names of my columns and Id like to arrange them as you see ("C", "D", "E", "F", "G", "H", "I", "J", "K"). In each tab, the ("VSP", "Temp", "GR", "N8", "N16", "N32", "N64", "Cond", "Velocity") are sorted differently. I want the code to go through each tab and sort them as i've defined in the 'cols' array. For example, put the entire "VSP" in the C column. Put the entire "Temp" in the D column and so on.

Sub sort_columns()  Dim sh As Worksheet, sh2 As Worksheet, lbls As Variant, cols As Variant
  Dim lr As Long, i As Long, lr2 As Long, f As Range


  Application.ScreenUpdating = False
  Set sh2 = Sheets("[COLOR=#ff0000]MyVBA[/COLOR]")
  lbls = Array([COLOR=#ff0000]"VSP", "Temp", "GR", "N8", "N16", "N32", "N64", "Cond", "Velocity"[/COLOR])
  cols = Array([COLOR=#ff0000]"C", "D", "E", "F", "G", "H", "I", "J", "K"[/COLOR])
  For Each sh In Sheets
    Select Case True
      Case Left(sh.Name, 3) = "[COLOR=#ff0000]Planilha[/COLOR]" Or sh.Name <> sh2.Name
        For i = 0 To UBound(lbls)
          Set f = sh.Rows(1).Find(lbls(i), , xlValues, xlWhole)
          If Not f Is Nothing Then
            lr = sh.Cells(Rows.Count, f.Column).End(xlUp).Row
            sh.Range(sh.Cells(2, f.Column), sh.Cells(lr, f.Column)).Copy
            lr2 = sh2.Cells(Rows.Count, cols(i)).End(xlUp).Row + 1
            sh2.Cells(lr2, cols(i)).PasteSpecial xlPasteValues
          End If
        Next
    End Select
  Next
  Application.CutCopyMode = False
End Sub

 

[DanteAmor]

What does the error say and on which line does it stop?

In the initial post you did not put the name of your destination sheet.
That is, all the data you will enter on a single sheet, that sheet name goes on this line:

Set sh2 = Sheets("[COLOR=#ff0000]Master[/COLOR]")

Change this line

Case Left(sh.Name, 3) = "Planilha" Or sh.Name <> sh2.Name

For this:

Case Left(sh.Name, [COLOR=#ff0000]8[/COLOR]) = "Planilha" Or sh.Name <> sh2.Name

Note: 8 is the number of letters of the word "planilha"

 

[alanlambden]

Set sh2 = Sheets("Master")
It stops here, "runtime error 9: Subscript out of range'


There is no destination sheet, I want to sort the tabs individually.

This way I can easily check for errors on each tab, then run some other VBA code to collate all of the tabs into one combined sheet.

 

[DanteAmor]

I misunderstood, I thought you wanted to pass the columns to a destination sheet.
I have to change the whole macro.

 

[DanteAmor]

Try this

Sub sort_columns()
  Dim sh As Worksheet, lbls As Variant, cols As Variant
  Dim cold As Long, i As Long, f As Range, colo  As Long
  '
  Application.ScreenUpdating = False
  lbls = Array("VSP", "Temp", "GR", "N8", "N16", "N32", "N64", "Cond", "Velocity")
  cols = Array("C", "D", "E", "F", "G", "H", "I", "J", "K")
  For Each sh In Sheets
    Select Case True
      Case Left(sh.Name, 8) = "Planilha"
        For i = 0 To UBound(lbls)
          Set f = sh.Rows(1).Find(lbls(i), , xlValues, xlWhole)
          If Not f Is Nothing Then
            sh.Columns(f.Column).Cut
            cold = Range(cols(i) & 1).Column
            colo = f.Column
            If colo < cold Then
              cold = cold + 1
              sh.Columns(cold).Insert Shift:=xlToRight
            ElseIf colo > cold Then
              sh.Columns(cold).Insert Shift:=xlToRight
            End If
          End If
        Next
    End Select
  Next
  Application.CutCopyMode = False
End Sub

 

[alanlambden]

Thanks Dante,

I cant seem to get this part working correctly. I have a feeling its in the columns headings. I'm gonna leave this, thanks for your time and help, its very much appreciated.