Thread: merge blocks of columns into a single page
View Single Post
 
Old 02-17-2018, 08:36 AM
p45cal's Avatar
p45cal p45cal is offline Windows 10 Office 2010 32bit
Expert
  
Join Date: Apr 2014
Posts: 871
p45cal has a reputation beyond reputep45cal has a reputation beyond reputep45cal has a reputation beyond reputep45cal has a reputation beyond reputep45cal has a reputation beyond reputep45cal has a reputation beyond reputep45cal has a reputation beyond reputep45cal has a reputation beyond reputep45cal has a reputation beyond reputep45cal has a reputation beyond reputep45cal has a reputation beyond repute
Default
Run the macro blah (which calls the macro CleanUp) on the workbook you attached.

Assumptions:
  • More than 2 cells merged on one row results in that row being deleted.
  • Exactly 2 merged cells need splitting using Text to columns with a space as delimiter (I have ignored whether they're latin or chinese characters).
  • ALL existing sheets in the workbook need processing.

A new sheet called Results is created (so there mustn't already be a sheet with that name).
All sheets are altered (merged cells unmerged, a row probably deteted at the bottom, and some cells processed with Text to Columns).

Near the bottom of the Results sheet there is a blank row; this is because the sheet Page 61 has blanks in the cells I4:L4.

It takes about 30 seconds to run here.

The code:
Code:
Sub blah()
Application.ScreenUpdating = False
With Application.FindFormat
  .Clear
  .MergeCells = True
End With
Set wbk = ActiveWorkbook
Set NewSht = Sheets.Add(after:=wbk.Sheets(wbk.Sheets.Count))
NewSht.Name = "Results"
Set Destn = NewSht.Range("A1")
For Each sht In wbk.Sheets
  If sht.Name <> "Results" Then
    CleanUp sht
    For Each rw In sht.Range("A1").CurrentRegion.Rows
      For i = 0 To 8 Step 4
        rw.Offset(, i).Resize(, 4).Copy Destn
        Set Destn = Destn.Offset(1)
      Next i
    Next rw
  End If
Next sht
With NewSht
  .Cells.WrapText = False
  .UsedRange.Columns.EntireColumn.AutoFit
  .UsedRange.Rows.EntireRow.AutoFit
End With
Application.ScreenUpdating = True
Application.FindFormat.Clear
End Sub

Sub CleanUp(theSheet)
myFieldInfo = Array(Array(1, 1), Array(2, 1), Array(3, 9), Array(4, 9), Array(5, 9), Array(6, 9), Array(7, 9), Array(8, 9), Array(9, 9), Array(10, 9))
Set xxx = theSheet.UsedRange.Find("*", LookIn:=xlFormulas, lookat:=xlWhole, searchformat:=True)
Do Until xxx Is Nothing
  Set ddd = xxx.MergeArea
  If ddd.Rows.Count = 1 And ddd.Cells.Count > 2 Then
    ddd.EntireRow.Delete
  Else
    ddd.MergeCells = False
    Application.DisplayAlerts = False
    ddd.Cells(1).TextToColumns DataType:=xlDelimited, TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=True, Space:=True, FieldInfo:=myFieldInfo
    Application.DisplayAlerts = True
  End If
  Set xxx = theSheet.UsedRange.Find("*", LookIn:=xlFormulas, lookat:=xlWhole, searchformat:=True)
Loop
End Sub
Reply With Quote