Alrighty,
Attached is your original workbook updated to include a macro that mimics the Desired Results you provided.
To run the Macro
1.Enable macros and then Press Alt+F8 on your keyboard
2. From the macro window select Test
3. Select the run option.
This macro will run and format everything as asked. To run it another time you will need to delete the created worksheet.
To use this macro into your workbook, open your workbook:
1.Press Alt+F8 on your keyboard
2.Clear the macro name box and type LocateCells in the blank box provided
3.Select the Create option
4.In between the Sub LocateCells() and End Sub copy and paste the code:
Dim ws As Worksheet, LR As String, i As Long, arr() As String, wsLR As String
Dim c As Range, fc As Range, d As Long
Dim x As Long, Darr() As String, y As Range, z As Range, t As Long
Sheets.Add(before:=Sheets(1)).Name = "Combined Data" 'Add a worksheet in front of the first worksheet and name it combined data
'In row 1 from columns A to F Add the following headings but splitting the text that following Split( but ;
ActiveSheet.Range("A1:F1") = Split("Company;Work-Life Balance;Development, Recognition and Feedback;Communication and Leadership;Workplace Culture/Perks;Benefits", ";")
'build a list of values to loop through, column headers
'this list will be used later to find the value on the worksheet and then find the values underneath
arr = Split("Work-Life Balance;Development, Recognition and Feedback;Communication and Leadership;Workplace Culture/Perks;Benefits", ";")
'Loop through each worksheet in this workbook that is not the first worksheet in this workbook
For Each ws In ThisWorkbook.Worksheets
If ws.Index > 1 Then 'if the worksheet in the loop is not the first worksheet then
With Sheets(1) 'with the newly added worksheet
LR = .Range("A6555").End(xlUp).Row + 1 'set LR equal to the first cell in column A that is blank
With ws 'with current worksheet in the loop
wsLR = .Range("A6555").End(xlUp).Row
.Range("B1").Copy 'copy cell B1 (company Name)
End With 'end with the current cell in the loop
.Range("A" & LR).PasteSpecial xlPasteValues ' in the added worksheet paste the value in to column A of the LR(variable defined above) row
With ws 'with the current worksheet in the loop
For i = LBound(arr) To UBound(arr) 'from the first item in the arr list to the last
'arr list defined above
For Each c In .Range("A10:D" & wsLR).Cells 'loop through cells from A10 to column D and the last row in the worksheet
If c.Value = arr(i) Then 'if the value in the current cell in the loop is equal to the current list item in the arr array then
'set the variable fc equal to the found cell whose value is equal
'to "SCORE" after the current cell in the loop, in the current cell in the loops column
Set fc = .Columns(c.Column).Find(What:="SCORE:", After:=.Cells(c.Row, c.Column), LookIn:=xlValues, LookAt:= _
xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
, SearchFormat:=False)
ReDim Darr(1 To fc.Row - c.Row - 1) 'reassign the number of items in list Darr
'creating a new list for the list under the categories
For x = 1 To fc.Row - c.Row - 1 'set variable x to loop through numbers 1 to the found cell's row and
'c's row minus 1
If x Mod fc.Row - c.Row - 1 Then ReDim Preserve Darr(1 To UBound(Darr) + (fc.Row - c.Row - 1)) 'reassign number of items in the list Darr
Darr(x) = c.Offset(x, 1).Value 'set the item in the darr list equal to the value in the cell next to the current cell in the loop, and down down number that x loop is on
Next x 'move to next number in the x loop
For d = LBound(Darr) To UBound(Darr) 'for each list item in the d loop
With Sheets(1) 'with the first tab in this workbook
For Each y In .Range("A1:F1").Cells 'loop through cells A1 through F1 (header rows)
If y.Value = arr(i) Then 'if the value of the cell in the current cell in the d loop
'is equal to the current list item in the arr list then
If .Cells(LR, y.Column).Value = vbNullString Then 'if the cell is empty then
.Cells(LR, y.Column).Value = Darr(d) 'add the first item in the d loop
Else
If Darr(d) <> vbNullString Then 'if it's not empty and the list item is not nothing then
.Cells(LR, y.Column).Value = .Cells(LR, y.Column).Value & "; " & Darr(d) 'combine the value in the cell with the item in the d list in the cell and seperate by ;
End If 'end if
End If 'end if
End If 'end if
Next y 'move to next y in the y loop
End With 'end with first sheet in the workbook
Next d 'move to next d in the d loop
End If 'end if
Next c 'move to next c in the c loop
Next i 'move to next i in the i loop
End With 'end with ws in the ws loop
End With 'end with added worksheet
End If 'end if statement
Next ws 'move to next worksheet in the loop
With Sheets(1)
With .Cells
.Font.Size = 9 'font size 9
.HorizontalAlignment = xlCenter 'align center
.VerticalAlignment = xlCenter 'align center vertically
.WrapText = True 'wrap text
End With
.Columns("A:F").ColumnWidth = 37.75 'column A through F width is 37.75
.Rows("2:" & LR).RowHeight = 114.75 'rows 2 to the last row height is 114.75
With .Rows("1:1") 'row 1
.AutoFit 'autofit
.Font.Bold = True 'bold text
End With
End With
Please note that this macro assumes that all worksheets are company names and there are no worksheets that you don't want included in the formatted worksheet. If this is not true for your worksheet , you might want to move all the worksheets that do not contains data you want included in the summary to the vbery beginning of the workbook and then you will need to change the following line in the code:
If ws.Index > 1 Then 'if the worksheet in the loop is not the first worksheet then
To the below, replacing 1 with the number that represents the first worksheet you wish to start with index number. Index number refers to the tab position +1. In the worksheet you sent me Accenture would be 1, Desired Results would be two and so on.
Also this macro assumes that all your company worksheets start their user entered data for the categories at a row greater than 10.
5.Anything that appears in green is comment I left to hopefully help you understand.
6.Exit out of the Visual Basic Window
7.Press Alt+F8 again and this time select the LocateCells macro
8.Select Run
Let me know if this works for you or if you have any questions.
LinkBack URL
About LinkBacks
Register To Reply
Re: Formula that combines text cells into single cell paragraph
Bookmarks