Microsoft Office Forums

Go Back   Microsoft Office Forums > >

Reply
 
Thread Tools Display Modes
  #1  
Old 02-17-2018, 08:36 AM
p45cal's Avatar
p45cal p45cal is offline merge blocks of columns into a single page Windows 10 merge blocks of columns into a single page Office 2010 32bit
Expert
 
Join Date: Apr 2014
Posts: 956
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
Reply

Tags
blocks, order



Similar Threads
Thread Thread Starter Forum Replies Last Post
merge blocks of columns into a single page Writing in columns and text blocks Vazrael Word 9 08-19-2016 12:20 AM
Merge csv data onto one A4 page containing columns gerrymac Word 1 04-17-2016 02:32 PM
merge blocks of columns into a single page Mail merge conditional adress blocks. Thrizian Mail Merge 2 07-17-2012 10:41 PM
merge blocks of columns into a single page how to use Building Blocks or controls to add a page verbster Word 11 03-06-2011 04:05 PM
merge blocks of columns into a single page moving data from single to multiple columns? mzimmers Excel 3 08-23-2010 08:20 AM

Other Forums: Access Forums

All times are GMT -7. The time now is 06:50 PM.


Powered by vBulletin® Version 3.8.11
Copyright ©2000 - 2025, vBulletin Solutions Inc.
Search Engine Optimisation provided by DragonByte SEO (Lite) - vBulletin Mods & Addons Copyright © 2025 DragonByte Technologies Ltd.
MSOfficeForums.com is not affiliated with Microsoft