PDA

View Full Version : Solved: Find last filled row IN PARAGRAPH



RV6555
09-03-2007, 12:48 AM
I have loads of text files imported in a workbook, each text file on its own worksheet. I need to extract certain data from the sheet, in order to present it in an organised manner and be able to further analyse the data. I have written quite some code yet, but I am stuck on this issue and cannot think of anything that would do the job. Please help. The part of a sheet looks like this:

- rank and percentage are in different columns (rank column A, percentage column B)

5.1 Sales Volume
NH:
1st 46.53%
2nd 4654207
3rd 16.68%
5th 7.04%

ZH:
1st 57.18%
2nd 4654207
4th 10.58%

Total volume
NH: 50
ZH: 14

5.2 Distribution
NH: 12.6%
NZ: 7.33%

In paragraph 5.1 there are market share figures. On some sheets there is one office, on other sheets there are several offices (up to 7 offices). In the table presented above there are two offices (NH and ZH). The information I need to extract is:
- name of the office
- its rank
- same for possible more offices

The name of the first office is a piece of cake:

'Copy name to cell D1
Range("D1").Value = Columns("A:A").Find(What:="5.1", _
LookAt:=xlWhole).Offset(1, 0).Value
'trim all thats not company name

'Copy rank to cell E1
Range("E1").Value = Columns("B:B").Find(What:="4654207", _
LookAt:=xlWhole).Offset(0, -1).Value

The logic I came to for the second (or further) office, search for last filled line of paragraph (in the case of NH it is 5th). Then offset(2,0) if content cell is not “total” or “5.2” THEN copy cell into D2. Here must be some kind of loop, until “total” or “5.2” has been reached.

After, I need to search for start paragraph 5.2. And in paragraph 5.2 look for the values collected in D1, D2, etc (name). If value in D1 (NH) is found THEN offset(0,1) and copy cell to F1.

Any help is greatly appreciated.

Roy

mdmackillop
09-03-2007, 05:29 AM
Can you post a sample?

RV6555
09-03-2007, 06:47 AM
Hi, see attached the file (all victicious figures). I left the VBA code there as well. Just to have an idea of the scale: I need to process some 1100 files one time, if I get it to work well I would like to do another 4 years of data (about 2400 files) and I will use the macro for 50 files that I receive monthly. I am really keen on solving this issue, but two days of reading internet resources have not brought me any further. Thanks for looking into this.

Roy

mdmackillop
09-03-2007, 09:13 AM
Do all office names end in a colon, and can you confirm that no other data in 5.1 and 5.2 will end in a colon.
Alternatively, do you have a list of all office names that can occur?

RV6555
09-04-2007, 01:38 AM
Hi, all offices do indeed end in a colon, there is another word ending in colon as well. however, the figures presented there I need to copy it, too, but to another column. This is the code I came up with so far:

'If next office, copy name of office
Dim roy As Range
Set roy = ActiveSheet.Range("A:A").Find(What:="5.1")
roy.End(xlDown).Select
If ActiveCell.Offset(2, 0) <> total Then Range("D2").Value = ActiveCell.Offset(2, 0)

'If next office, copy rank
If ActiveCell.Offset(3, 1) = 4654207 Then Range("E2").Value = ActiveCell.Offset(3, 0)
If ActiveCell.Offset(4, 1) = 4654207 Then Range("E2").Value = ActiveCell.Offset(4, 0)
If ActiveCell.Offset(5, 1) = 4654207 Then Range("E2").Value = ActiveCell.Offset(5, 0)
If ActiveCell.Offset(6, 1) = 4654207 Then Range("E2").Value = ActiveCell.Offset(6, 0)
If ActiveCell.Offset(7, 1) = 4654207 Then Range("E2").Value = ActiveCell.Offset(7, 0)

mdmackillop
09-04-2007, 02:29 AM
Your coding is, i think, too specific. My thoughts on the approach are
Identify the ranges for 5.1 and 5.2
Search these ranges for office names, from a list, if available, or defined by the colon
Return the data base on the search results.
Do you have a list of possible office names? If not, what other recognisable attribures do the names contain. Length, All caps, colon etc.

RV6555
09-04-2007, 02:47 AM
Sorry for not answering that question. I can make a list of all office names manually, there might be up to 100 different offices. Every text file's name states the alphabetical range of offices included into that file (say range ABD - HGJ includes mentioned 2 offices and the 3 offices CED, FDE, and GTR).

Distinguisable attributes are that all office abbreviations are written in capital letters and have a maximum length of 5 characters. No other words in 5.1 and 5.2 are completely written in capital letters.

I figured my code was very specific and prone to errors due to different formatting over the years (i have about 5-6 years of data). However, this was the best I could get to with my limited beginners knowledge of VBA. Really appreciate your help.

mdmackillop
09-04-2007, 12:48 PM
This uses the data in cell D33. If it is not typical, another search method can be devised.

Option Explicit

Sub Macro1()
Dim c As Range, Source As Range
Dim Strt As Long, Endd As Long, i As Long
Dim Arr, a
Set c = Columns(2).Find(What:="period").Offset(1)
Arr = Split(c, "-")
Strt = Columns(1).Find(What:=5.1, LookIn:=xlValues).Row
Endd = Columns(1).Find(What:=6, LookIn:=xlValues).Row - Strt
Set Source = Cells(Strt, 1).Resize(Endd, 2)
For Each a In Arr
With Source
Set c = .Find(a & ":", LookIn:=xlValues, searchorder:=xlRows)
If Not c Is Nothing Then
i = i + 1
Cells(i, 4) = a
End If
Set c = .Find(4654207, After:=c, LookIn:=xlValues, searchorder:=xlRows).Offset(0, -1)
Cells(i, 5) = c
Cells(i, 6) = .Find(a & ":", After:=c, LookIn:=xlValues, searchorder:=xlRows).Offset(0, 1)
End With
Next
End Sub

RV6555
09-04-2007, 11:59 PM
Wow! This just does the job, thank you so much MD! I'm really impressed how this works, thanks a lot for your help.

Roy

mdmackillop
09-05-2007, 12:05 AM
It will work on sheets where the office names are in Column B, after a cell containing Period and are separated with a "-" , if that is not the case on other sheets, it may not work.

mdmackillop
09-05-2007, 12:45 AM
A more robust version. It finds all terms with a colon in column A, excludes certain terms, From, To, Date, Offices, and searches for the rest.

Option Compare Text
Option Base 1

Sub GetOffices()
Dim arr(), tmp, Rw As Long
Dim d

Rw = Cells(Rows.Count, 1).End(xlUp).Row
ReDim arr(Rw)

For i = 1 To Rw
arr(i) = Range("A" & i)
Next
tmp = Filter(arr, ":", True, 1)


Set d = CreateObject("Scripting.Dictionary")
On Error Resume Next
For Each t In tmp
Select Case t
Case "From:", "To:", "Date:", "Offices:"
'Do nothing
Case Else
d.Add t, t
End Select
Next
On Error GoTo 0

GetData d.Items
End Sub

Sub GetData(arr)
Dim c As Range, Source As Range
Dim Strt As Long, Endd As Long, i As Long
Dim a
Set c = Columns(2).Find(What:="period").Offset(1)
Strt = Columns(1).Find(What:=5.1, LookIn:=xlValues).Row
Endd = Columns(1).Find(What:=6, LookIn:=xlValues).Row - Strt
Set Source = Cells(Strt, 1).Resize(Endd, 2)
For Each a In arr
With Source
Set c = .Find(a, LookIn:=xlValues, searchorder:=xlRows)
If Not c Is Nothing Then
i = i + 1
Cells(i, 4) = a
End If
Set c = .Find(4654207, After:=c, LookIn:=xlValues, searchorder:=xlRows).Offset(0, -1)
Cells(i, 5) = c
Cells(i, 6) = .Find(a, After:=c, LookIn:=xlValues, searchorder:=xlRows).Offset(0, 1)
End With
Next
End Sub

RV6555
09-05-2007, 05:09 AM
I have deciphered the first code, understand it, and it works great. The second code I cannot get to work, although it looks more stable as you said. So I guess I'll stick with your first, thanks again!

mdmackillop
09-05-2007, 05:17 AM
Here's some comments on the second code

'Allow for capitalisation
Option Compare Text
'Set the arrays to start at 1
Option Base 1

Sub GetOffices()
Dim arr(), tmp, Rw As Long
Dim d

'Find the last rown column 1
Rw = Cells(Rows.Count, 1).End(xlUp).Row
'Set the array size to hold data
ReDim arr(Rw)

'Read each cell into the array
For i = 1 To Rw
arr(i) = Range("A" & i)
Next
'Run a filter on the array, looking for ":" to a new array
tmp = Filter(arr, ":", True, 1)

'This is to get unique values
'Create a dictionary object which only allows unique items
Set d = CreateObject("Scripting.Dictionary")
'to carry on execution if the item exists
On Error Resume Next
'For each item in the array
For Each t In tmp
Select Case t
'If it is not one of these
Case "From:", "To:", "Date:", "Offices:"
'Do nothing
Case Else
'Add it to the dictionary
d.Add t, t
End Select
Next
On Error GoTo 0
'Pass the array to the Search module
GetData d.Items
End Sub

RV6555
09-05-2007, 07:21 AM
Thanks for the comments, but still I cannot get it to work. I tested your first version with several files and it renders the exact results I am looking for, so thanks again...