I've put together this code to extract and id code data from an excel
workbook, but have come across quite a few bugs. I've tried to put
comments in the VB code describing what's going on at each stage. I
would appreciate it if someone could clear up the errors and get it
running. Thanks.

Dave Shapiro

Option Explicit
Sub extraction_codingmacro()

Dim wks As Worksheet
Dim SumWks As Worksheet
Dim myCell As Range
Dim oRow As Long
Dim myRng As Range

Set SumWks = Worksheets.Add
SumWks.Range("a1").Resize(1, 7).Value _
= Array("country", "source", "indicator", "data type",
"subgroup", "year", "value")

oRow = 1
For Each wks In ActiveWorkbook.Worksheets
If wks.Name = SumWks.Name Or wks.Name = "criteria file" Or _
wks.Name = "reference" Then
'do nothing
Else
wks.Select
Call preparefile
With wks
Set myRng = .Range("d8:aa" & _
.Cells(.Rows.Count, "A").End(xlUp).Row)
End With
With SumWks
For Each myCell In myRng.Cells
If myCell.Interior.ColorIndex = 3 Then

'the next two lines are supposed to filter out
all
the rows with the words
' "GSD" in the B column of the row and rows
with
the
words "AAA" in the D column
' of the row. But this doesn`t seem to work.
Could
you adjust this?

'If myCell.Cells(myCell.Row, "B").Text <
"GSD"
Then
'If InStr(1, myCell.Cells(myCell.Row,
"D").Text,"AAA", vbTextCompare) = 0
'Then
oRow = oRow + 1
.Cells(oRow, "A").Value _
= wks.Cells(myCell.Row, "A").Value
.Cells(oRow, "B").Value _
= wks.Cells(myCell.Row, "B").Value
.Cells(oRow, "C").Value _
= wks.Cells(myCell.Row, "C").Value
.Cells(oRow, "D").Value _
= wks.Cells(myCell.Row, "D").Value
.Cells(oRow, "E").Value _
= wks.Cells(myCell.Row, "E").Value
.Cells(oRow, "F").Value _
= wks.Cells(7,
myCell.Column).Value
.Cells(oRow, "G").Value _
= myCell.Value
End If
'End If
'End If
Next myCell
End With
End If
Next wks

Call addmeasurementcolumn
Call noduplicaterows
Call extractall
Call codedata

End Sub

Sub preparefile()
'this procedure prepares the country worksheet. But due to the
irregular
number of rows from
'the top of the page. The country name is sometimes on the 1st row,
the
second row or the third row. It can differ from worksheet to
worksheet.
Tthe table structure,
template and headings are always the same though. The name of the
country,
for example, is always in the cell to the right of the cell containing
the
words "country". This works for one country here. How could it be
adjusted to work for all countries?

Cells.Select 'this is just a copy-paste special value as
the
original
Selection.Copy 'sheets are pivot tables and need to be made
into
values
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone,
SkipBlanks:=
_
False, Transpose:=False
Columns("A:A").Select
Application.CutCopyMode = False
Selection.Insert Shift:=xlToRight
Selection.Insert Shift:=xlToRight 'two columns are created
Range("D1").Select
Selection.Copy
Range("A1").Select
ActiveSheet.Paste 'the name of the country is pasted
here.
Range("D2").Select
Application.CutCopyMode = False
Selection.Copy
Range("B1").Select
ActiveSheet.Paste 'the name of the indicator is pasted here
Range("E1").Select
Application.CutCopyMode = False
ActiveCell.FormulaR1C1 = "x"
Columns("A:E").Select
Selection.SpecialCells(xlCellTypeBlanks).Select
Selection.FormulaR1C1 = "=R[-1]C" 'all blanks are filled in
with
right categories
Cells.Select
Selection.Copy
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone,
SkipBlanks:=
_
False, Transpose:=False
Application.CutCopyMode = False
Call cleanworksheet

End Sub

Sub cleanworksheet()
'For some reason, an error comes up here

Dim c As Range

For Each c In ActiveSheet.UsedRange
c = WorksheetFunction.Clean(c)
Next
'
End Sub

Sub addmeasurementcolumn()
'this procedure does the deletion of the "value" column and addition of
the
"measurement" column
'It doesn't seem to be working. Also I don't think the word "number"
is
copying for all
'the rows in the dataset. The number of rows varies from sheet to
sheet.

ActiveSheet.Cells.Select
Cells.Find(What:="value", After:=ActiveCell, LookIn:=xlFormulas,
LookAt
_
:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext,
MatchCase:= _
False).Activate
Columns("F:F").Select
Selection.Clear
Range("F1").Select
ActiveCell.FormulaR1C1 = "measurement"
Range("F2").Select
ActiveCell.FormulaR1C1 = "number"
Range("F2").Select
Selection.AutoFill Destination:=Range("F2:F19"),
Type:=xlFillDefault
Range("F2:F19").Select
Cells.Select
Selection.Copy
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone,
SkipBlanks:=
_
False, Transpose:=False
End Sub

Sub noduplicaterows()

ActiveSheet.Cells.Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
Range("A1:E19").AdvancedFilter Action:=xlFilterCopy,
CopyToRange:=Range(
_
"A21"), Unique:=True
Range("A1:A20").Select
Range("A20").Activate
Selection.EntireRow.Delete
Cells.Select
Selection.Copy
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone,
SkipBlanks:=
_
False, Transpose:=False
Sheets("Sheet1").Select
Sheets("Sheet1").Name = "criteria file"
Range("A1").Select
End Sub


Sub extractall()
' this procedure uses the "criteria file" created above to extract the
full
set of data from
' the "source data" file

Sheets("source data").Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
Range("A1:I53263").AdvancedFilter Action:=xlFilterInPlace,
CriteriaRange:= _
Sheets("criteria file").Range("A1:F7"), Unique:=False
ActiveWindow.ScrollColumn = 5
ActiveWindow.ScrollColumn = 1
Selection.Copy
Worksheets.Add
Sheets("sheet2").Name = "final data"
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone,
SkipBlanks:=
_
False, Transpose:=False
Cells.Select
Application.CutCopyMode = False
Selection.Copy
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone,
SkipBlanks:=
_
False, Transpose:=False

End Sub

Sub codedata()
Dim rng As Range, rng2 As Range
Dim rng1 As Range, cell As Range
Dim sStr As String, sStr1 As String
'this procedure codes all the data rows in the file "final data". I
have
used a combination
'cacatenation and vlookup technique to do the coding in mass. But
actually,
would it be possible
'to redo this section so that it cacatenates, vlookups and codes one
row at
a time? For each
row, I`d also
'like to be able to check one row at a time whether there is an id code
for
this row or
'not. And to put the rows which are id coded on one sheet and those
for
which there is no id
'code on a separate sheet.

'prepare final data worksheet for coding
Sheets("final data").Select
Set rng = Cells(ActiveCell.Row, "IV").End(xlToLeft)
Set rng1 = Range(ActiveCell, Cells(Rows.Count,
ActiveCell.Column).End(xlUp))
ActiveCell.EntireColumn.Insert
Set rng2 = Range(rng1(1), rng)
Debug.Print rng2.Address
For Each cell In rng2
sStr1 = LCase(Cells(1, cell.Column))
If sStr1 = "indicator" Or sStr1 = "subgroup" Or sStr1 =
"classification"
_
Or sStr1 = "gender" Or sStr1 = "measurement" Then
sStr = sStr & cell.Address(0, 0) & "&"
End If
Next
If Len(Trim(sStr)) = 0 Then
rng1.Offset(0, -1).EntireColumn.Delete
Exit Sub
End If
sStr = "=" & Left(sStr, Len(sStr) - 1)
rng1.Offset(0, -1).Formula = sStr

Columns("A:A").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:=
_
False, Transpose:=False
Application.CutCopyMode = False
Selection.Insert Shift:=xlToRight

'code from reference worksheet
Sheets("reference").Select
Range("B1").Select
Set rng = Cells(ActiveCell.Row, "IV").End(xlToLeft)
Set rng1 = Range(ActiveCell, Cells(Rows.Count,
ActiveCell.Column).End(xlUp))
ActiveCell.EntireColumn.Insert
Set rng2 = Range(rng1(1), rng)
Debug.Print rng2.Address
For Each cell In rng2
sStr1 = LCase(Cells(1, cell.Column))
If sStr1 = "indicator" Or sStr1 = "subgroup" Or sStr1 =
"classification"
_
Or sStr1 = "gender" Or sStr1 = "measurement" Then
sStr = sStr & cell.Address(0, 0) & "&"
End If
Next
If Len(Trim(sStr)) = 0 Then
rng1.Offset(0, -1).EntireColumn.Delete
Exit Sub
End If
sStr = "=" & Left(sStr, Len(sStr) - 1)
rng1.Offset(0, -1).Formula = sStr

Columns("B:B").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:=
_
False, Transpose:=False

Sheets("final data").Select
Application.CutCopyMode = False
ActiveCell.FormulaR1C1 =
"=VLOOKUP(RC[1],reference!RC:R[368]C[1],2,FALSE)"
Range("A1").Select
Selection.AutoFill Destination:=Range("A1:A13"), Type:=xlFillDefault
Range("A1:A13").Select
Columns("A:A").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:=
_
False, Transpose:=False
Sheets("reference").Select
ActiveWindow.ScrollRow = 1
Application.CutCopyMode = False
Selection.Delete Shift:=xlToLeft
Range("A1").Select

End Sub




*** Sent via Developersdex http://www.developersdex.com ***
Don't just participate in USENET...get rewarded for it!