Disconnected
11-27-2012, 09:44 AM
Abstract: Function merges data from several sheets together into one spreadsheet.
Concrete:
sRANGE is set to a constantProblem:
I need sRANGE to become variable based upon the cell count in the sheet that is being copied from so I do not have to manually tweak the ranges based upon the data set.
When I attempt to set the bolded code to a range that isn't a constant the code fails.
Ideas? :o)
Sub MergeSheets()
Dim iSheet, iTargetRow As Long, oCell As Object, bRowWasNotBlank As Boolean
Dim iTop, iLeft, iBottom, iRight As Long
Const sRANGE = "A1:F2000"
Sheets(1).Select: Sheets.Add
Sheets(1).Select
Cells.Select
Selection.Clear
bRowWasNotBlank = True
For iSheet = 4 To ThisWorkbook.Sheets.Count: DoEvents
For Each oCell In Sheets(iSheet).Range(sRANGE).Cells: DoEvents
If oCell.Column = 1 Then
If bRowWasNotBlank Then iTargetRow = iTargetRow + 1
bRowWasNotBlank = False
End If
If oCell.MergeCells Then
bRowWasNotBlank = True
If oCell.MergeArea.Cells(1).Row = oCell.Row Then
If oCell.MergeArea.Cells(1).Column = oCell.Column Then
Sheets(1).Cells(iTargetRow, oCell.Column) = oCell
iTop = iTargetRow
iLeft = oCell.Column
iBottom = iTop + oCell.MergeArea.Rows.Count - 1
iRight = iLeft + oCell.MergeArea.Columns.Count - 1
Sheets(1).Range(Cells(iTop, iLeft), Cells(iBottom, iRight)).MergeCells = True
End If
End If
End If
If Len(oCell) Then bRowWasNotBlank = True
Sheets(1).Cells(iTargetRow, oCell.Column) = oCell
Next oCell
Next
'Format merged sheet.
Sheets(1).Select
Cells.Select
Cells.EntireColumn.AutoFit
Range("B:B,D:D,F:F").Select
Selection.Delete Shift:=xlToLeft
ActiveSheet.Name = "DDMI Application Data"
'Sets Column E horizontal alignment to Left.
Range("C:C,E:E").Select
With Selection
.HorizontalAlignment = xlLeft
End With
Range("A1").Select
Sheets("Macros").Select
Range("A1").Select
End Sub
Concrete:
sRANGE is set to a constantProblem:
I need sRANGE to become variable based upon the cell count in the sheet that is being copied from so I do not have to manually tweak the ranges based upon the data set.
When I attempt to set the bolded code to a range that isn't a constant the code fails.
Ideas? :o)
Sub MergeSheets()
Dim iSheet, iTargetRow As Long, oCell As Object, bRowWasNotBlank As Boolean
Dim iTop, iLeft, iBottom, iRight As Long
Const sRANGE = "A1:F2000"
Sheets(1).Select: Sheets.Add
Sheets(1).Select
Cells.Select
Selection.Clear
bRowWasNotBlank = True
For iSheet = 4 To ThisWorkbook.Sheets.Count: DoEvents
For Each oCell In Sheets(iSheet).Range(sRANGE).Cells: DoEvents
If oCell.Column = 1 Then
If bRowWasNotBlank Then iTargetRow = iTargetRow + 1
bRowWasNotBlank = False
End If
If oCell.MergeCells Then
bRowWasNotBlank = True
If oCell.MergeArea.Cells(1).Row = oCell.Row Then
If oCell.MergeArea.Cells(1).Column = oCell.Column Then
Sheets(1).Cells(iTargetRow, oCell.Column) = oCell
iTop = iTargetRow
iLeft = oCell.Column
iBottom = iTop + oCell.MergeArea.Rows.Count - 1
iRight = iLeft + oCell.MergeArea.Columns.Count - 1
Sheets(1).Range(Cells(iTop, iLeft), Cells(iBottom, iRight)).MergeCells = True
End If
End If
End If
If Len(oCell) Then bRowWasNotBlank = True
Sheets(1).Cells(iTargetRow, oCell.Column) = oCell
Next oCell
Next
'Format merged sheet.
Sheets(1).Select
Cells.Select
Cells.EntireColumn.AutoFit
Range("B:B,D:D,F:F").Select
Selection.Delete Shift:=xlToLeft
ActiveSheet.Name = "DDMI Application Data"
'Sets Column E horizontal alignment to Left.
Range("C:C,E:E").Select
With Selection
.HorizontalAlignment = xlLeft
End With
Range("A1").Select
Sheets("Macros").Select
Range("A1").Select
End Sub