• Status: Solved
  • Priority: Medium
  • Security: Public
  • Views: 209
  • Last Modified:

Consolidating a list

EE Professionals,

I have a number of text entries that are in a column but at different point/cells that have blanks between them.  When the data refreshes, the entries change and so do the locations of the data; although it's still within a range within the same column.  What I'm looking for is the formula that looks at a column and takes all of the text entries and lists them in sheet 2 in a single, list (no blanks).

Example:

Cells in Sheet 1 are in Column D and in Rows 4, 5, 8, 12, 14 and 18.  What I'm looking for is in Sheet 2, Column D, the text on Sheet 1, is put in Rows 4, 5, 6, 7, 8 and 9 (single list).  

Thank you!

B.
0
Bright01
Asked:
Bright01
  • 2
  • 2
1 Solution
 
dlmilleCommented:
Ok - app searches column D sheet1, omitting first row as header?  then outputs results in column D sheet2 (appending), from second row forward, without blank rows.

Here's the code:
 
Sub removeBlkDiffSht()
Dim wkb As Workbook
Dim srcSht As Worksheet
Dim destSht As Worksheet
Dim outCursor As Range
Dim fRange As Range
Dim lastRow As Long
Dim firstAddress As String

    Set wkb = ThisWorkbook
    Set srcSht = wkb.Sheets("Sheet1")
    Set destSht = wkb.Sheets("Sheet2")
    Set outCursor = destSht.Range("D" & destSht.Rows.Count).End(xlUp).Offset(1, 0) 'append to column D
    
    lastRow = srcSht.Range("D" & srcSht.Rows.Count).End(xlUp).Row
    
    'omit first row?
    With srcSht.Range("D2:D" & lastRow)
    
        Set fRange = .Find(what:="*")
        If Not fRange Is Nothing Then
            firstAddress = fRange.Address
            
            Do
            
                outCursor.Value = fRange.Value
                Set outCursor = outCursor.Offset(1, 0)
                
                Set fRange = .FindNext(fRange)
            Loop While Not fRange Is Nothing And firstAddress <> fRange.Address
        End If
    End With
    
End Sub

Open in new window


See attached demo workbook.

Enjoy!

Dave
removeBlanksToSht2-r1.xlsm
0
 
Bright01Author Commented:
Dave,

This is great...... however, one problem that I found that I missed when I first posed the question; when I test it it put the blanks in on the output for me..... and the reason why is that I have formulas in the cells that are both populated and blank on the source sheet.  Is there a way to distinguish "results" from cells with formulas?  Just to be clear; in the source cells, there are is a formula that either populates or leaves blank the cell.  If the cell is blank the formula is still there. So the code you wrote sees the cell as "populated" and displays it anyway on the output sheet.

The formula in the fields in the cells, blank or populated is; =IF(ROW()>=(ROW(Priority_Formulas!$D$4)+SUM(Priority_Formulas!$B$2:$B$12)-1),"",IF(Priority_Formulas!G6>0,"",INDEX(INDEX(PriorityDB!$E:$E,MATCH(Strategic_Priorities!$B$1,PriorityDB!$A:$A,0)):INDEX(PriorityDB!$E:$E,MATCH(Strategic_Priorities!$B$1,PriorityDB!$A:$A,1)),ROW(Priority_Formulas!A3)+Priority_Formulas!$B$2-(SUM(Priority_Formulas!$G$4:G6)))))

Sorry for the additional confusion.  Thank you.

B.
0
 
dlmilleCommented:
Ok - I put a test to ensure the result was = "" before skipping.

 
Sub removeBlkDiffSht()
Dim wkb As Workbook
Dim srcSht As Worksheet
Dim destSht As Worksheet
Dim outCursor As Range
Dim fRange As Range
Dim lastRow As Long
Dim firstAddress As String

    Set wkb = ThisWorkbook
    Set srcSht = wkb.Sheets("Sheet1")
    Set destSht = wkb.Sheets("Sheet2")
    Set outCursor = destSht.Range("D" & destSht.Rows.Count).End(xlUp).Offset(1, 0) 'append to column D
    
    lastRow = srcSht.Range("D" & srcSht.Rows.Count).End(xlUp).Row
    
    'omit first row?
    With srcSht.Range("D2:D" & lastRow)
    
        Set fRange = .Find(what:="*")
        If Not fRange Is Nothing Then
            firstAddress = fRange.Address
            
            Do
                If fRange.Value <> "" Then
                    outCursor.Value = fRange.Value
                    Set outCursor = outCursor.Offset(1, 0)
                End If
                
                Set fRange = .FindNext(fRange)
            Loop While Not fRange Is Nothing And firstAddress <> fRange.Address
        End If
    End With
    
End Sub

Open in new window

removeBlanksToSht2-r2.xlsm
0
 
Bright01Author Commented:
Dave,

Great work as always...... and I could even follow it in the code!  Much thanks.  Hope you have a great week.

All the best,

B.
0
Question has a verified solution.

Are you are experiencing a similar issue? Get a personalized answer when you ask a related question.

Have a better answer? Share it in a comment.

Join & Write a Comment

Featured Post

Cloud Class® Course: Microsoft Office 2010

This course will introduce you to the interfaces and features of Microsoft Office 2010 Word, Excel, PowerPoint, Outlook, and Access. You will learn about the features that are shared between all products in the Office suite, as well as the new features that are product specific.

  • 2
  • 2
Tackle projects and never again get stuck behind a technical roadblock.
Join Now