trying to compress 3 lines into one

snoforlife · #1 01-19-2016, 02:29 PM

i copied the data off of a website and the formatted it so that each different type of data ended up if a different column. (name, address, ect.) now i want to take that data and compress it all down to one line but there are 2 problems 1st all of the empty spots actually have a formula in them (ex: =a1), also one spot has #VALUE! and i need to get rid off all of them and the second is that one of the columns (name) might have more than one row filled up and i need both names (or to at least know that there are more names)

img attached

macropod · #2 01-19-2016, 08:17 PM

This would be far easier for someone to work on if you attached a workbook with some sample data & formulae, rather than leaving them to guess what they have to deal with. You do this via the paperclip symbol on the 'Go Advanced' tab at the bottom of this screen.

snoforlife · #3 01-20-2016, 01:49 PM

the document is attached

macropod · #4 01-20-2016, 04:45 PM

Try the following macro, after which you probably won't need any of your formulae.

Code:

Sub CleanUp()
Application.ScreenUpdating = False
Dim i As Long, j As Long, k As Long
With ActiveSheet
  With .UsedRange
    .Cells.Replace What:=Chr(160), Replacement:="", LookAt:=xlPart, SearchOrder:= _
        xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
    .UnMerge
    .VerticalAlignment = xlCenter
    .WrapText = False
    .HorizontalAlignment = xlLeft
    .Font.ColorIndex = xlAutomatic
    .Font.Underline = False
  End With
  While .Shapes.Count > 0
    .Shapes(1).Delete
  Wend
  .Columns(9).Delete
  .Columns(8).Delete
  .Columns(6).Delete
  .Columns(5).Delete
  .Columns(4).Delete
  .Columns(2).Delete
  For i = 1 To .UsedRange.Rows.Count - 1
    If .Cells(i, 6).Value = "MORTGAGE" Then
      .Cells(i, 5).Value = "MORTGAGE"
      .Cells(i, 6).Value = -(.Cells(i + 1, 6).Value)
    End If
    If Trim(.Cells(i, 2).Value) Like "####-#####" Then
      .Cells(i, 2).Value = Trim(.Cells(i, 2).Value)
      For j = i To .UsedRange.Rows.Count
        If Trim(.Cells(j, 1).Value) <> "" Then Exit For
      Next
      .Cells(i, 9).Value = .Cells(j, 1).Value
      For k = i + 1 To j
        If .Cells(k, 3).Value <> "" Then
          .Cells(i, 3).Value = .Cells(i, 3).Value & " / " & .Cells(k, 3).Value
        End If
      Next
    End If
  Next
  For i = .UsedRange.Rows.Count To 2 Step -1
    If .Cells(i, 2).Value = "" Then .Rows(i).EntireRow.Delete
  Next
  .Columns(1).Delete
  .UsedRange.Rows.AutoFit
  .UsedRange.Columns.AutoFit
End With
Application.ScreenUpdating = True
End Sub

snoforlife · #5 01-25-2016, 12:38 PM

thank you that worked great.
i was also wondering if there is a way to take the street address and the county and put it into google or something to find the full address with zipcode

macropod · #6 01-25-2016, 02:42 PM

Quote:

Originally Posted by snoforlife

i was also wondering if there is a way to take the street address and the county and put it into google or something to find the full address with zipcode

Possibly, but that's not something I have experience with. Besides which, your data includes no country or state/territory info and it seems from your attached workbook you regarded the locality information as also being wrong (or at least unreliable).

snoforlife · #7 01-25-2016, 02:45 PM

there all have the same state and county ... ny and tompkins county

macropod · #8 01-25-2016, 05:06 PM

If have found some code for retrieving zip codes from the USPS website but, using that website, you can't look up zip codes by county - a town/city name is required. See: https://tools.usps.com/go/ZipLookupA...1&refresh=true

Only a small number of zip codes can be retrieved for your data. Bearing that in mind, you might try:

Code:

Option Explicit
Dim ieObj As Object
 
Sub CleanUp()
Application.ScreenUpdating = False
Dim i As Long, j As Long, k As Long
With ActiveSheet
  With .UsedRange
    .Cells.Replace What:=Chr(160), Replacement:="", LookAt:=xlPart, SearchOrder:= _
        xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
    .UnMerge
    .VerticalAlignment = xlCenter
    .WrapText = False
    .HorizontalAlignment = xlLeft
    .Font.ColorIndex = xlAutomatic
    .Font.Underline = False
  End With
  While .Shapes.Count > 0
    .Shapes(1).Delete
  Wend
  .Columns(11).Delete
  .Columns(9).Delete
  .Columns(8).Delete
  .Columns(6).Delete
  .Columns(5).Delete
  .Columns(4).Delete
  .Columns(2).Delete
  For i = 1 To .UsedRange.Rows.Count - 1
    If .Cells(i, 5).Value = "MORTGAGE" Then
      .Cells(i, 5).Value = -(.Cells(i + 1, 5).Value)
    End If
    If Trim(.Cells(i, 2).Value) Like "####-#####" Then
      .Cells(i, 2).Value = Trim(.Cells(i, 2).Value)
      For j = i To .UsedRange.Rows.Count
        If Trim(.Cells(j, 1).Value) <> "" Then Exit For
      Next
      .Cells(i, 8).Value = .Cells(j, 1).Value
      .Cells(i, 9).Value = Replace(Replace(.Cells(i, 7).Value, "City of ", ""), "Town of ", "")
      For k = i + 1 To j
        If .Cells(k, 3).Value <> "" Then
          .Cells(i, 3).Value = .Cells(i, 3).Value & " / " & .Cells(k, 3).Value
        End If
      Next
    End If
  Next
  For i = .UsedRange.Rows.Count To 2 Step -1
    If .Cells(i, 2).Value = "" Then .Rows(i).EntireRow.Delete
  Next
  .Columns(7).Delete
  .Columns(1).Delete
  Call ZipUpdate
  .UsedRange.Rows.AutoFit
  .UsedRange.Columns.AutoFit
End With
Application.ScreenUpdating = True
End Sub
 
Sub ZipUpdate()
Application.ScreenUpdating = False
Dim i As Long
Set ieObj = CreateObject("InternetExplorer.Application")
With ActiveSheet
  For i = 2 To .UsedRange.Rows.Count
    .Cells(i, 8).Value = ZipCode(.Cells(i, 6).Value, .Cells(i, 7).Value, "NY")
  Next
End With
ieObj.Quit: Set ieObj = Nothing
Application.ScreenUpdating = True
End Sub
 
Function ZipCode(Addr As String, City As String, State As String) As String
Dim URL As String, AD As String, Ct As String, St As String, Data As String
Dim Zip As String, i As Long, ieDoc As Object
URL = "https://tools.usps.com/go/ZipLookupResultsAction!input.action?resultMode=0&companyName=&" & _
"address1=" & Addr & "&address2=&city=" & City & "&state=" & State & "&urbanCode=&postalCode=&zip="
With ieObj
  .navigate URL
  Do Until (.readyState = 4 And Not .Busy)
    DoEvents
  Loop
  Set ieDoc = .document
  Data = ieDoc.body.innerText
  Data = Right(Data, Len(Data) - 2400)
  If InStr(1, Data, "Here's the full address") = 0 Then
    ZipCode = ""
  Else
    Data = Mid(Data, InStr(1, Data, "Here's the full address") + 94, 100)
    ZipCode = Mid(Data, InStr(1, Data, "-") - 5, 10)
  End If
End With
Set ieDoc = Nothing
End Function

Do note that the zip-code look-ups greatly increase the processing time. However, you can also run the ZipUpdate macro separately (after the other processing has been done). Accordingly, you might want to delete/comment-out the line:
Call ZipUpdate
and run the CleanUp macro without it. You could then run the ZipUpdate macro after you've fixed up the locality details.

Thread Tools
Show Printable Version Email this Page
Display Modes
Linear Mode Switch to Hybrid Mode Switch to Threaded Mode

Similar Threads
Thread	Thread Starter	Forum	Replies	Last Post
Word 2013 - Compress pictures	charleswpj	Drawing and Graphics	1	11-08-2015 12:36 AM
Deleting grid lines but keeping the axis lines	CoffeeNut	Excel	0	04-01-2013 01:50 PM
How can I compress slide shows under Apple?	Cliff	PowerPoint	0	01-10-2012 12:04 PM
Compress Emails as Attachment	SJT	Outlook	2	11-30-2011 01:36 PM
Getting blank lines instead of supressed lines.	Welshie82	Mail Merge	2	11-14-2011 01:41 AM