Unmerge and paste cells down with vba - vba

I am facing the problem to proecess a report I got into a useful structured excel model.
My problem is that cells in this report are merged and now I would like to unmerge them to process the information much easier.
I tried to record something using the macro recorder, but I am unsure how to automate it on every cell in the sheet.
I would like to let the output look like that:
This is the part I recorded:
Sub Macro1()
Range("A2:A3").Select
With Selection
.HorizontalAlignment = xlGeneral
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = True
End With
Selection.UnMerge
Range("A2").Select
Selection.AutoFill Destination:=Range("A2:A3")
Range("A2:A3").Select
End Sub
Any suggestions how to rewrite this macro to do the merging and pasting automatically?
Appreciate your replies!
UPDATE
I tried to use the selection, however, I am currently facing the problem of not knowing how to get next cell:
Sub split()
'
'Dim C As Double
'Dim R As Double
Dim Rng As Range
'select cells
Set Rng = Selection
'C = Rng
'R = 10
For Each cell In Rng
'starts in row 2 and A -> cell 2,1 is the first cell or A2
cell.Select
With Selection
.HorizontalAlignment = xlGeneral
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = True
End With
Selection.UnMerge
'Cells(R + 1, C) = Cells(R, C)
If cell.Value = "" Then MsgBox ("Finished splitting and copying!"): End
' If C = 7 Then C = 0: R = R + 2
Next cell
End Sub

Sub Macro1()
NbRows = Sheets("Feuil1").UsedRange.Rows.Count - 1
NbCols = 9 ' If it doesn't change
Range("A2:I11").Copy Destination:= _
Range("K2")
Range("K:S").MergeCells = False ' remove merge
For i = 2 To NbRows ' Number of rows
For j = 11 To NbCols + NbCols ' Number of cols
If Cells(i, j) = "" Then
Cells(i, j) = Cells(i - 1, j).Value
End If
Next j
Next i
End Sub
My code copy-paste the datas from the first table to the cell "K2" (as in your example). Then, you remove the merge that will left some blanks. What you want to do is if cells(i , 1) is empty, then you just use the data from above (cells(i-1, 1))

if the data you want to change is on columns a to g and your are starting from row 2 and assuming all of the cell are not empty
try this code:
Sub split()
'
Dim C As Double
Dim R As Double
C = 1
R = 2
For C = 1 To 7
Cells(R, C).Select
With Selection
.HorizontalAlignment = xlGeneral
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = True
End With
Selection.UnMerge
Cells(R + 1, C) = Cells(R, C)
If Cells(R, C).Value = "" Then MsgBox ("PROJECT ENDED"): End
If C = 7 Then C = 0: R = R + 2
Next C
End Sub
Please save your data before running the macro. You cannot undo.

Related

Excel macro adjust cell height

My script moves data to excel template. Codewords is changed for relevant info.
All works well if TPLNR and AUFNR is filled. The cell is two rows in height. But if i leave AUFNR or TPLNR blank - cell height not ajusted. This is macro used to fill and adjust every row in table.
Sub Mac1()
'
' Mac1
'
Dim i As Integer
i = 12
'
Do While Range("L" & i).Value <> "THE END"
If Range("L" & i).Value = "M" Then
...
ElseIf Range("L" & i).Value = "T" Then
Range("A" & i & ":D" & i).Select
With Selection
.HorizontalAlignment = xlCenter
.Orientation = 0
.WrapText = True
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = True
End With
Selection.Merge
With Selection
.HorizontalAlignment = xlLeft
.VerticalAlignment = xlBottom
.WrapText = True
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = True
End With
Selection.Font.Italic = True
End If
i = i + 1
Loop
Call AutoFitMergedCellRowHeight
Columns("L:L").Select
Selection.Delete Shift:=xlToLeft
End Sub
Sub AutoFitMergedCellRowHeight()
Dim CurrentRowHeight As Single, MergedCellRgWidth As Single
Dim CurrCell As Range
Dim ActiveCellWidth As Single, PossNewRowHeight As Single
Dim StartCell As Range, c As Range, MergeRng As Range, Cell As Range
Dim a() As String, isect As Range, i
'Take a note of current active cell
Set StartCell = ActiveCell
'Create an array of merged cell addresses that have wrapped text
For Each c In ActiveSheet.UsedRange
If c.MergeCells Then
With c.MergeArea
If .Rows.Count = 1 And .WrapText = True Then
If MergeRng Is Nothing Then
Set MergeRng = c.MergeArea
ReDim a(0)
a(0) = c.MergeArea.Address
Else
Set isect = Intersect(c, MergeRng)
If isect Is Nothing Then
Set MergeRng = Union(MergeRng, c.MergeArea)
ReDim Preserve a(UBound(a) + 1)
a(UBound(a)) = c.MergeArea.Address
End If
End If
End If
End With
End If
Next c
Application.ScreenUpdating = False
'Loop thru merged cells
For i = 0 To UBound(a)
Range(a(i)).Select
With ActiveCell.MergeArea
If .Rows.Count = 1 And .WrapText = True Then
'Application.ScreenUpdating = False
CurrentRowHeight = .RowHeight
ActiveCellWidth = ActiveCell.ColumnWidth
For Each CurrCell In Selection
MergedCellRgWidth = CurrCell.ColumnWidth + MergedCellRgWidth
Next
.MergeCells = False
.Cells(1).ColumnWidth = MergedCellRgWidth
.EntireRow.AutoFit
PossNewRowHeight = .RowHeight
.Cells(1).ColumnWidth = ActiveCellWidth
.MergeCells = True
.RowHeight = IIf(CurrentRowHeight > PossNewRowHeight, _
CurrentRowHeight, PossNewRowHeight)
End If
End With
MergedCellRgWidth = 0
Next i
StartCell.Select
Application.ScreenUpdating = True
'Clean up
Set CurrCell = Nothing
Set StartCell = Nothing
Set c = Nothing
Set MergeRng = Nothing
Set Cell = Nothing
End Sub
What could i do to get rows after 12 to look like it intended to? With 1x height.
Making the rows equal size is quite a standard VBA task.
Just try to put this logic away from your code. The only 3 things you should know is the starting row, the ending row and the size. Thus, you may be able to do it quite well. In the code below change the parameters of Call AllRowsAreEqual(4, 10, 35) in order to make it work for you.
Option Explicit
Sub AllRowsAreEqual(lngStartRow As Long, lngEndRow As Long, lngSize)
Dim lngCounter As Long
For lngCounter = lngStartRow To lngEndRow
Cells(lngCounter, 1).RowHeight = lngSize
'Debug.Print lngCounter
Next lngCounter
End Sub
Public Sub Main()
Call AllRowsAreEqual(4, 10, 35)
End Sub

Macros applicable on one column can be applicable to all column in excel VB

I have excel sheet prepared as a data entry sheet called “INPUT SHEET”. Data is added in various columns against fixed certain no. of rows of this “INPUT SHEET”.
At the end of each row I have provided one macro button which picks the value from each column and creates another new sheet.
The problem is that I have 100 such columns and I want to avoid editing each macro to work against each column. I want a single macro which identifies column against which the button is pressed and accordingly works on that column only.
Sample macro for COLUMN U is as below: I want a little modification in this sheet so that same code can be applicable to all coulmns.
' Macro1 Macro===ROW U
'
' Create new sheet copying from DATASHEET 1 before last sheet
'
Worksheets("DATASHEET 1").Copy before:=Sheets(Worksheets.Count)
Set wks = ActiveSheet
Sheets("INPUT").Select
Range("U10").Select
Selection.Copy
' Retaining the name of sheet
'
Range("U150").Select
ActiveSheet.Paste
wks.Name = Range("U10").Value
' Copying the notes
'
Worksheets(Range("u10").Value).Activate
Range("D62:BF87").Select
Selection.ClearContents
Range("AY6").Value = "2"
Range("A7:BF7").Select
ActiveCell.FormulaR1C1 = "=INPUT!R[3]C[20]"
Dim i As Integer, j As Integer
j = 61
For i = 63 To 88
Sheets("INPUT").Select
If Cells(i, 21).Value = "YES" Then
j = j + 1
Worksheets(Range("U10").Value).Activate
Range(Cells(j, 4), Cells(j, 58)).Select
With Selection
.HorizontalAlignment = xlGeneral
.VerticalAlignment = xlCenter
.WrapText = True
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = True
End With
Selection.UnMerge
Sheets("INPUT").Select
Cells(i, 2).Copy
Worksheets(Range("U10").Value).Activate
Cells(j, 4).PasteSpecial Paste:=xlPasteValues
Range(Cells(j, 4), Cells(j, 58)).Select
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = True
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Selection.Merge
With Selection
.HorizontalAlignment = xlLeft
.VerticalAlignment = xlCenter
.WrapText = True
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = True
End With
End If
Next i
Rather than having 100 buttons, I would probably work with just one, and move it according to the selected cell. That way each time the cursor moves, the button moves and you could then use the activecell.column method to sum that column.
The code you could use would be something like:
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
ActiveSheet.Shapes("Button 1").Left = Cells(40, ActiveCell.Column).Left
End Sub
In the sheet of the workbook you are working on. The button in row 40 will move to the selected column.

Merge cells in different ranges

I have the following:
I expect the following:
I am using this code:
Sub merge_cells()
Application.DisplayAlerts = False
Dim r As Integer
Dim mRng As Range
Dim rngArray(1 To 4) As Range
r = Range("A65536").End(xlUp).Row
For myRow = r To 2 Step -1
If Range("A" & myRow).Value = Range("A" & (myRow - 1)).Value Then
For cRow = (myRow - 1) To 1 Step -1
If Range("A" & myRow).Value <> Range("A" & cRow).Value Then
Set rngArray(1) = Range("A" & myRow & ":A" & (cRow + 0))
Set rngArray(2) = Range("B" & myRow & ":B" & (cRow + 0))
Set rngArray(3) = Range("C" & myRow & ":C" & (cRow + 0))
Set rngArray(4) = Range("D" & myRow & ":D" & (cRow + 0))
For i = 1 To 4
Set mRng = rngArray(i)
mRng.Merge
With mRng
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 90
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = True
End With
Next i
myRow = cRow + 2
Exit For
End If
Next cRow
End If
Next myRow
Application.DisplayAlerts = True
End Sub
what I get is:
Question: how to achieve this?
Actually in my original data, the first three columns have data every 88 rows starting from row 3 and the column D should get merged every four rows.
Your code does not distinguish between the different columns in any way. If you know how many rows to merge you can simply search for cells and then do the merge based on column number. Here is one such approach which uses a pair of arrays to track how many rows to merge and then what formatting to apply.
You will need to change the row counts in the array definition. Sounds like you want (87,87,87,3) based on your edit. I did (11,11,11,3) to match your example though. This is the real fix to your code; it uses the Column number to determine how many rows to merge.
I also just typed some values into the spreadsheet and used SpecialCells to get only the cells with values. If your data matches your example, this works fine.
Edit includes unmerging cells first per OP request.
Sub MergeAllBasedOnColumn()
Dim rng_cell As Range
Dim arr_rows As Variant
Dim arr_vert_format As Variant
'change these to the actual number of rows
'one number for each column A, B, C, D
arr_rows = Array(11, 11, 11, 3)
'change these if the formatting is different than example
arr_vert_format = Array(True, True, True, False)
'unmerge previously merged cells
Cells.UnMerge
'get the range of all cells, mine are all values
For Each rng_cell In Range("A:D").SpecialCells(xlCellTypeConstants)
'ignore the header row
If rng_cell.Row > 2 Then
'use column to get offset count
Dim rng_merge As Range
Set rng_merge = Range(rng_cell, rng_cell.Offset(arr_rows(rng_cell.Column - 1)))
'merge cells
rng_merge.Merge
'apply formatting
If arr_vert_format(rng_cell.Column - 1) Then
'format for the rotated text (columns A:C)
With rng_merge
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 90
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
End With
Else
'format for the other cells (column D)
With rng_merge
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = False
End With
End If
End If
Next rng_cell
End Sub
Before
After

Copy data from one sheet and paste into the first blank cell in column A of another sheet

Sub ImportFixed()
'
Sheets("Front-Page").Select
Sheets("SPROC").Visible = True
Sheets("SPROC").Select
ThisWorkbook.RefreshALL
DoEvents
'Selection.ListObject.QueryTable.Refresh BackgroundQuery:=False
Sheets("SPROC").Select
Range("J2").Select
Range(Selection, Selection.End(xlToLeft)).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Sheets("Master-Data-Sheet").Select
Range("A1914").Select
ActiveSheet.Paste
Sheets("SPROC").Select
Range("N2").Select
Range(Selection, Selection.End(xlDown)).Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Master-Data-Sheet").Columns("N:N").Range("N1914").Paste
Cells.Select
Application.CutCopyMode = False
With Selection.Font
.Size = 9
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.TintAndShade = 0
End With
With Selection.Font
.Name = "Calibri"
.Size = 9
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.TintAndShade = 0
.ThemeFont = xlThemeFontMinor
End With
Columns("A:H").Select
With Selection
.HorizontalAlignment = xlGeneral
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
With Selection
.HorizontalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Columns("M:N").Select
With Selection
.HorizontalAlignment = xlGeneral
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
With Selection
.HorizontalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Range("L16108").Select
Range("J2105").Select
Range(Selection, Selection.End(xlDown)).Select
Range("J2137").Select
Range("N2137").Select
Sheets("SPROC").Select
ActiveWindow.SelectedSheets.Visible = False
ActiveWindow.ScrollWorkbookTabs Sheets:=-2
Sheets("Master-Data-Sheet").Select
End Sub
I have a report that has a sheet named SPROC. This sheet is refreshed each Monday and pulls through data for that day from a SQL query (any other data on that sheet is overwritten) . What I then want to do is select ALL the data (Columns A:N - The number of rows changes each week so the range isn't fixed) and paste it into the first blank cell in column A on a sheet named Master-Data-Sheet. This second sheet contains ALL the data for previous weeks and is used to populate ALL my pivot tables and graphs etc on various other worksheets. At present I have recorded a Macro but instead of finding the last blank row, it is using a specific range which means that when I run the macro, it overwrites data in the Master Data file. Any Suggestions?
I have included a copy of the VBA code (it also does a lot of other functions so apologies if it is a little long). I think it is lines 20 and 359 where the issue is occurring but I have no idea what to do to fix it (I have tried ALL manner of different variations).
Pretty classical matter, must have a lot of similar question and please get rid of scrolls and things like this in record macros...
try this :
Sub Macro2()
'
Dim ShIn As Worksheet
Dim ShOut As Worksheet
Set ShIn = ThisWorkbook.Sheets("SPROC")
Set ShOut = ThisWorkbook.Sheets("Master-Data-Sheet")
'ShIn.Cells(2, 1).End(xlToRight).Column
Dim RgTotalInput As String
Dim RgTotalOutput As String
RgTotalInput = "$A$2:$" & ColLet(ShIn.Cells(1, 1).End(xlToRight).Column) & "$" & ShIn.Cells(Rows.Count, 1).End(xlUp).Row
RgTotalOutput = "$A$" & ShOut.Cells(Rows.Count, 1).End(xlUp).Row + 1
ShIn.Range(RgTotalInput).Copy Destination:=ShOut.Range(RgTotalOutput)
End Sub
Public Function ColLet(ByVal ColNb As Integer) As String
Dim ColLetTemp As String
Select Case ColNb
Case Is < 27
ColLetTemp = Chr(64 + ColNb)
Case Is > 26
If Int(ColNb / 26) <> ColNb / 26 Then
ColLetTemp = Chr(64 + Int(ColNb / 26)) & Chr(64 + ColNb - 26 * Int(ColNb / 26))
Else
ColLetTemp = Chr(64 + Int(ColNb / 26) - 1) & Chr(64 + 26)
End If
Case Else
End Select
ColLet = ColLetTemp
End Function

Range in Excel VBA

I have written this code to merge a few lines in each column, from column C to AZ.
For some reason the range does not match the one I was expecting, in this case the code merges the cells C8:C10 then D8:D12, E8:E12, and so on. lines = 2 in this example.
I don't understand why aren't the ranges matching if lines value is not changing inside the for.
Thanks!
For columns = 0 To 49
Range(Range("C8").Offset(0, columns), Range("C8").Offset((lines), columns)).Select
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 90
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = True
End With
next comlumns
Columns is a reserved word. And you said that this code did run?
If I change that to a valid variable then the code runs. The problem is the way you are using Offset
?[C8].offset(2).address after the way you merge will give you $C$12
Also avoid the use of .Select INTERESTING READ And not to mention fully qualify your objects. For example your range and cell objects are not fully qualified and may give you error.
I think, this is what you are trying to achieve?
Sub Sample()
Dim ws As Worksheet
Dim rng As Range
Dim i As Long, rw As Long
Set ws = ThisWorkbook.Sheets("Sheet1")
rw = 2
With ws
For i = 3 To 52
Set rng = .Range(.Cells(8, i), .Cells(8 + rw, i))
With rng
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 90
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = True
End With
Next i
End With
End Sub