Disconnected
11-27-2012, 02:14 PM
Abstract:
Search entire sheet for all duplicate values in one column, then take all of the matching data in the next column and merge them all into one cell, then remove all of the duplicate rows except for the first one.
Concrete:
Column C contains a unique identifier that may or may not repeat itself.
If the identifier in Column C repeats itself, for the first row in that entire range where the identifier is repeated, I want to set Dx as a set cell.
I then copy cell D for each row that repeats and merge all of that data into the first Dx cell.
The d.exists creates an object where one doesn't exist before. This allows me to skip past a row where only one cell of the data exists.
I set the e.Font.ColorIndex so I could visualize the code "seeing" each subsequent cell in Column C (to help me learn).Problem:
I cannot figure out how to loop this such it will concatenate all the data into one cell.
For example:
A random range (C3:C7 in this case) contains the same value 2438.
I want to merge all data in D3:D7 into D3, then remove the rows 4:7.
First row found in the range will always remain.
All subsequent rows will be deleted.What say you, oh VBA masters? I cannot thank you enough for your help.
Code has been bolded and sized.
Sub MergeSheetsDDMI()
Dim iSheet, iTargetRow As Long, oCell As Object, bRowWasNotBlank As Boolean
Dim iTop, iLeft, iBottom, iRight As Long
Dim appidRange As Range
Dim Cell
Dim d As Object, e, f
Set d = CreateObject("scripting.dictionary")
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).Cells(1, 1).CurrentRegion.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").Select
Selection.Delete Shift:=xlToLeft
ActiveSheet.Name = "DDMI Application Data"
'Sets Column E horizontal alignment to Left.
Range("D:D").Select
With Selection
.HorizontalAlignment = xlLeft
End With
Range("A1").Select
'Copies all different application versions to first cell of that AppID, that row, column D.
For Each e In Intersect(Columns(3), ActiveSheet.Range("C2:C7")) 'Change ActiveSheet to ActiveSheet.UsedRange
If e.Value <> vbNullString Then
If Not d.exists(e.Value) Then d(e.Value) = 1 Else _
e.Font.ColorIndex = 32
e.End(xlToLeft).Offset(, 3).Copy
MsgBox "Boo."
End If
Next
'Sheets("Macros").Select
Range("A1").Select
End Sub
Search entire sheet for all duplicate values in one column, then take all of the matching data in the next column and merge them all into one cell, then remove all of the duplicate rows except for the first one.
Concrete:
Column C contains a unique identifier that may or may not repeat itself.
If the identifier in Column C repeats itself, for the first row in that entire range where the identifier is repeated, I want to set Dx as a set cell.
I then copy cell D for each row that repeats and merge all of that data into the first Dx cell.
The d.exists creates an object where one doesn't exist before. This allows me to skip past a row where only one cell of the data exists.
I set the e.Font.ColorIndex so I could visualize the code "seeing" each subsequent cell in Column C (to help me learn).Problem:
I cannot figure out how to loop this such it will concatenate all the data into one cell.
For example:
A random range (C3:C7 in this case) contains the same value 2438.
I want to merge all data in D3:D7 into D3, then remove the rows 4:7.
First row found in the range will always remain.
All subsequent rows will be deleted.What say you, oh VBA masters? I cannot thank you enough for your help.
Code has been bolded and sized.
Sub MergeSheetsDDMI()
Dim iSheet, iTargetRow As Long, oCell As Object, bRowWasNotBlank As Boolean
Dim iTop, iLeft, iBottom, iRight As Long
Dim appidRange As Range
Dim Cell
Dim d As Object, e, f
Set d = CreateObject("scripting.dictionary")
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).Cells(1, 1).CurrentRegion.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").Select
Selection.Delete Shift:=xlToLeft
ActiveSheet.Name = "DDMI Application Data"
'Sets Column E horizontal alignment to Left.
Range("D:D").Select
With Selection
.HorizontalAlignment = xlLeft
End With
Range("A1").Select
'Copies all different application versions to first cell of that AppID, that row, column D.
For Each e In Intersect(Columns(3), ActiveSheet.Range("C2:C7")) 'Change ActiveSheet to ActiveSheet.UsedRange
If e.Value <> vbNullString Then
If Not d.exists(e.Value) Then d(e.Value) = 1 Else _
e.Font.ColorIndex = 32
e.End(xlToLeft).Offset(, 3).Copy
MsgBox "Boo."
End If
Next
'Sheets("Macros").Select
Range("A1").Select
End Sub