![]() |
|
#1
|
||||
|
||||
![]()
Run the macro blah (which calls the macro CleanUp) on the workbook you attached.
Assumptions:
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 |
![]() |
Tags |
blocks, order |
|
![]() |
||||
Thread | Thread Starter | Forum | Replies | Last Post |
![]() |
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 |
![]() |
Thrizian | Mail Merge | 2 | 07-17-2012 10:41 PM |
![]() |
verbster | Word | 11 | 03-06-2011 04:05 PM |
![]() |
mzimmers | Excel | 3 | 08-23-2010 08:20 AM |