Sub transferit()
Dim ws As Worksheet, cRng As Range, i As Long, j As Long
Application.ScreenUpdating = False
Call Unmerge_CenterAcross
For j = 1 To 3
For i = 5 To 7
With Sheets(j).Columns(i)
.TextToColumns Destination:=.Cells(1, 1), FieldInfo:=Array(1, 1), TrailingMinusNumbers:=True
End With
Next
Next
With Sheet4.Range("B9:D" & Sheet4.Range("B" & Rows.Count).End(xlUp).Row)
Sheet1.Range("B3").Resize(.Rows.Count, .Columns.Count).Value = .Value
End With
With Sheet4.Range("G9:G" & Sheet4.Range("G" & Rows.Count).End(xlUp).Row)
Sheet1.Range("E3").Resize(.Rows.Count, .Columns.Count).Value = .Value
End With
With Sheet3.Range("G9:G" & Sheet3.Range("G" & Rows.Count).End(xlUp).Row)
Sheet1.Range("F3").Resize(.Rows.Count, .Columns.Count).Value = .Value
End With
Sheet1.Range("G3:G" & Sheet1.Range("F" & Rows.Count).End(xlUp).Row).NumberFormat = 0
For Each cRng In Sheet1.Range("G3:G" & Sheet1.Range("F" & Rows.Count).End(xlUp).Row)
cRng = Application.WorksheetFunction.Sum(cRng.Offset(, -2), cRng.Offset(, -1))
Next
Sheet1.Range("A1:A2,B1:B2,C1:C2,D1:D2,G1:G2").Merge
For j = 2 To 3
Sheets(j).Range("A1:G2").Merge
Sheets(j).Range("C5").HorizontalAlignment = xlCenter
Next
Application.ScreenUpdating = True
End Sub
Sub Unmerge_CenterAcross()
'adapted from Erik Van Geit
'080808
'merged cells will be unmerged
'contents will be centered across merged area
Dim lr As Long, LC As Long, i As Long, j As Long, icnt As Long
Dim cntUnmerged As Long, cntMerged As Long, mergeRng As Range
Dim checkmerged As Boolean, LastMerged As String
Dim AppSetCalc As Integer, StatusBarVisible As Boolean
Dim msg As String, MaxRc As Long, ColorMe As Boolean
For icnt = 1 To 3
With Sheets(icnt)
'needing xlCellTypeLastCell: else if last cell is merged wrong area will be found
lr = .Cells.Find(what:="*", SearchOrder:=xlRows, SearchDirection:=xlPrevious, LookIn:=xlValues).Row
LC = .Cells.Find(what:="*", SearchOrder:=xlColumns, SearchDirection:=xlPrevious, LookIn:=xlValues).Column
With .Cells(lr, LC)
If .MergeCells Then
lr = lr + .MergeArea.Rows.Count - 1
LC = LC + .MergeArea.Columns.Count - 1
End If
End With
If .Range(.Cells(1, 1), .Cells(lr, LC)).MergeCells = False Then
MsgBox "no merged cells on this sheet", 48, "EXIT"
Exit Sub
End If
MaxRc = 5
ColorMe = 0
With Application
.ScreenUpdating = False
AppSetCalc = .Calculation
.Calculation = xlCalculationManual
StatusBarVisible = .DisplayStatusBar
.DisplayStatusBar = True
.EnableCancelKey = xlErrorHandler
End With
For i = 1 To lr
On Error Resume Next
checkmerged = .Range(.Cells(i, 1), .Cells(i, LC)).MergeCells
'error occurs when MergeArea intersects row and contains more rows
'checkmerged is TRUE when MergeArea is in one row
If Err Or checkmerged Then
Err.Clear
For j = 1 To LC
With .Cells(i, j)
If .Resize(1, 1).MergeCells Then
cntMerged = cntMerged + 1
On Error GoTo stopit
With .MergeArea
If .Rows.Count <= MaxRc Then
cntUnmerged = cntUnmerged + 1
.UnMerge
.HorizontalAlignment = xlCenterAcrossSelection
If ColorMe Then .Interior.ColorIndex = 3
Else
LastMerged = .Address(0, 0)
End If
End With
End If
End With
Next j
End If
Application.StatusBar = "rows checked: " & Round(i / lr, 2) * 100 & "%"
Next i
End With
Next
stopit:
With Application
.EnableCancelKey = xlDisabled
.ScreenUpdating = True
.Calculation = AppSetCalc
.StatusBar = False
.DisplayStatusBar = StatusBarVisible
End With
End Sub
