asked on

Macro help

Hi I currently have to do the following by hand to 30 spreadsheets. I’m wondering if someone can write a macro to do this for me. Since I have 30 of these, is it possible to put them all in the same folder and run them all at once, or will I have to copy and paste the macro 30 times? Below are the steps I take and also an attached before and after spreadsheet to show what I am talking about.

a.      Center all data
b.      Format date to xx/xx/xxxx
c.      If there is a row with no = 0 and species = ATS – it gets deleted.
d.      Check that dates are consecutive and year = current year.
If there is a non-consecutive date, it’s highlighted in yellow. If there is a year that is not the current year, the cell is highlighted in yellow.
e.      Change 0’s in the grid field to nulls
f.      Check that there are no site numbers that occur less than 5 times.
If they occur less than 5 times they are highlighted in yellow.
g.      Check that there are no 0’s for length and weight
If there are 0’s highlight them in yellow.
h.      Check the length ranges for each species
All but YEP = 5 – 45
YEP 0.5 – 15
If anything falls outside of the range it’s highlighted in yellow.
i.      Check the weight ranges for each species
All but YEP = .1 – 30
YEP = .1 – 2 or 50 to 900
If anything falls outside of the range it’s highlighted in yellow.
j.      Check that for each date there is only one number listed for site and grid.
k.      If there are mixed sites and grids within a date – highlight in yellow that whole chunk of data.
l.      Check scale field
If species = YEP or WAE, scale = spine
If species = COS, BUR, FAT, SMT, scale should be = none
If species = LAT, sites = between 160 and 197, scale = none
Everything else, scale = scale
Anything that falls outside of those rules should be highlighted in yellow.
m.      Count each species by month and site and create a new worksheet to hold those data in table form. I don’t care what order the species are listed in, as long as they are all included. There will be different ones that show up in each spreadsheet. I would like the sites numbers listed in order.
n.      Insert a new column in A = “site” (three digits) & “year” (last two digits only) & “no” (four digits) & “-“ & “species”. Label column “New_biodata_ID”.
o.      Insert a new column in B = to column about without the “-“ & species. Label new column Old_biodata_ID
p.      Insert a third column, labeled “type” insert the word “BIO” for all records in that field.
q.      Insert a new column after weight called R/D.
Before.xls
After.xls

aikimark

are these 30 worksheets in the same workbook?

If in a single workbook, you can group the worksheets before you do your formatting. The formatting will apply to all sheets in the group.

If separate workbooks, are the workbooks in a single directory? Are they they only workbook files in that directory? If not, can they be easily selected by a file name pattern?

I think the the new sheet with the monthly counts will probably be solved by a pivot table. But that usually requires the data to be on a single worksheet.

Richard Daneke

Macros can be stored in an Excel file and used in that file, or stored in your 'Personal Macor Workbook' to be available to you on any open workbook, or stored in an Excel file that, when open, can be used on any other open workbook.
So, you will NOT have to copy a macro into each workbook.

Richard Daneke

Please state the version that you are using. The file is in Ecel 97-2003 format. Macro coding techniques can vary by version.

Coaster_brook_trout

ASKER

This is Microsoft office Professional Edition 2003.

There are 30 separate workbooks. I keep them all in the same folder, on my desktop, called "biodata". They each have different names though. There is nothing else in the folder except these workbooks.

It would be neat to use Personal Macro Workbook but I don't know how to set that up.

Thanks!

aikimark

Do you need to do the formatting/tweaking in each workbook, or do you need to consolidate the data into a single workbook/worksheet before you tweak?

Rob Brockett

If your answer to Aikimark's question is that you need to consolidate the data into a single wb/ws you may find Ron De Bruin's free addin helpful. It is quite flexible & easy to use and can be sourced from his site: http://www.rondebruin.nl/merge.htm

hth
Rob

Coaster_brook_trout

ASKER

I would prefer to keep them all in separate workbooks. This is so I can send the workbook with errors back to the original data enterer.

aikimark

After the inserts, are your new column A and column B the first two columns?

Coaster_brook_trout

ASKER

Yes

aikimark

What rule caused the yellow block for No=62..74?

aikimark

Your Old_biodata_ID data does not match your description.

Coaster_brook_trout

ASKER

aikimark - rule j. "Check that for each date there is only one number listed for site and grid". So for date 7/20/2011 they should only have been collecting data from site 48 - but now there is a site 2 listed. So I want the whole block of data flagged so I can check the dates and sites for all the samples collected on that date.

The old bioID does match the description. It's the new one without the "-" species abbreviation.

aikimark

for 4/23/2011, there are two sites, but only the 4 site is highlighted

for (6/18/2011, 9/2/2011) , nothing is highlighted

Coaster_brook_trout

ASKER

Oh that's OK - I probably didn't get them all by hand. For 4/23 I highlighted that site for the other rule (f. Check that there are no site numbers that occur less than 5 times.If they occur less than 5 times they are highlighted in yellow.) but it would be fine if the whole block was highlighted for that date. I just missed 6/18 and 9/2 - they should definitely be highlighted.

aikimark

Is there a hierarchy to these highlights? If multiple rules apply to a cell, how are you to know which rule(s) apply? In the case of the 4/23 block, if the 4 cell is already highlighted, wouldn't we reduce/muddle the information by highlighting the entire block?

Coaster_brook_trout

ASKER

Nope all it's doing is calling my attention to the cell, as long as it's highlighted I don't care which rule is doing it. Once my attention is on the cell, I check the entire record against it's paper copy.

aikimark

This version of the code will do the formatting and highlighting. I'll tackle the counting sometime later. You might want to try your hand at creating a pivot table to get your counts.

Option Explicit

Public Sub Q_27432239()
    Dim rng As Range
    Dim rngArea As Range
    Dim rngRow As Range
    Dim rngCell As Range
    Dim wks As Worksheet
    Dim dtPriorDate As Date
    Dim dicUnique As Object
    Dim varItem As Variant
    Dim rngFind As Range
    Dim strAddr As String
    Dim lngLoop As Long
    Dim dtPrior As Date
    Dim dtNext As Date
    
    Application.ScreenUpdating = False      'for best performance
    
    'c.      If there is a row with no = 0 and species = ATS – it gets deleted.
    Set rng = Worksheets("BiodataEntryFrm").Range("A1").CurrentRegion
    Worksheets("BiodataEntryFrm").Range("A1").CurrentRegion.AutoFilter field:=2, Criteria1:="ATS"
    Worksheets("BiodataEntryFrm").Range("A1").CurrentRegion.AutoFilter field:=1, Criteria1:=0
    Set rng = Intersect(rng, Worksheets("BiodataEntryFrm").Cells.SpecialCells(xlVisible))
    'Debug.Print rng.Areas.Count, rng.Address
    For Each rngArea In rng.Areas
        If rngArea.Row = 1 Then
            For Each rngRow In rngArea.Rows
                If rngRow.Row = 1 Then
                Else
                    rngRow.EntireRow.Delete
                End If
            Next
        Else
            rngArea.EntireRow.Delete
        End If
    Next
    Worksheets("BiodataEntryFrm").Range("A1").CurrentRegion.AutoFilter
    Set rng = Worksheets("BiodataEntryFrm").Range("A1").CurrentRegion

    Set rng = Worksheets("BiodataEntryFrm").Range("A1").CurrentRegion
    'a.      Center all data
    rng.Cells.HorizontalAlignment = xlHAlignCenter
    
    'b.      Format date to xx/xx/xxxx
    rng.Columns(3).NumberFormat = "mm/dd/yyyy;@"
    
    'd.      Check that dates are consecutive and year = current year.
    '   If there is a non-consecutive date, it’s highlighted in yellow.
    '   If there is a year that is not the current year, the cell is highlighted in yellow.
    dtPriorDate = CDate(rng.Cells(2, 3).Text)
    For Each rngCell In rng.Columns(3).Cells
        If rngCell.Row = 1 Then
        Else
            If dtPriorDate > CDate(rngCell.Text) Then
                rngCell.Interior.Color = vbYellow
            End If
            If Year(CDate(rngCell.Value)) <> Year(Date) Then
                rngCell.Interior.Color = vbYellow
            End If
            dtPriorDate = CDate(rngCell.Text)
        End If
    Next
    
    'e.      Change 0’s in the grid field to nulls
    rng.Columns(5).Replace "0", vbNullString, xlWhole
    
    'f.      Check that there are no site numbers that occur less than 5 times.
    '   If they occur less than 5 times they are highlighted in yellow.
    Set dicUnique = CreateObject("scripting.dictionary")
    For Each rngCell In rng.Columns(4).Cells
        If rngCell.Row = 1 Then
        Else
            If dicUnique.exists(rngCell.Value) Then
                dicUnique(rngCell.Value) = dicUnique(rngCell.Value) + 1
            Else
                dicUnique.Add rngCell.Value, 1
            End If
        End If
    Next
    For Each varItem In dicUnique
        If dicUnique(varItem) < 5 Then
            Set rngFind = rng.Columns(4).Find(what:=dicUnique(varItem), after:=rng.Cells(1, 4), lookat:=xlWhole)
            strAddr = rngFind.Address
            Do
                rngFind.Interior.Color = vbYellow
                Set rngFind = rng.Columns(4).Find(what:=dicUnique(varItem), after:=rngFind, lookat:=xlWhole)
            Loop Until strAddr = rngFind.Address
        End If
    Next
    
    'g.      Check that there are no 0’s for length and weight
    '   If there are 0’s highlight them in yellow.
    Worksheets("BiodataEntryFrm").Range("A1").CurrentRegion.AutoFilter field:=12, Criteria1:=0
    Set rng = Intersect(rng, Worksheets("BiodataEntryFrm").Cells.SpecialCells(xlVisible))
    For Each rngArea In rng.Areas
        For Each rngCell In rngArea.Columns(12).Cells
            If rngCell.Row = 1 Then
            Else
                rngCell.Interior.Color = vbYellow
            End If
        Next
    Next
    Worksheets("BiodataEntryFrm").Range("A1").CurrentRegion.AutoFilter
    Set rng = Worksheets("BiodataEntryFrm").Range("A1").CurrentRegion
    
    Worksheets("BiodataEntryFrm").Range("A1").CurrentRegion.AutoFilter field:=13, Criteria1:=0
    Set rng = Intersect(rng, Worksheets("BiodataEntryFrm").Cells.SpecialCells(xlVisible))
    For Each rngArea In rng.Areas
        For Each rngCell In rngArea.Columns(13).Cells
            If rngCell.Row = 1 Then
            Else
                rngCell.Interior.Color = vbYellow
            End If
        Next
    Next
    Worksheets("BiodataEntryFrm").Range("A1").CurrentRegion.AutoFilter
    Set rng = Worksheets("BiodataEntryFrm").Range("A1").CurrentRegion
        
    'h.      Check the length ranges for each species
    '   All but YEP = 5 – 45
    '   YEP 0.5 – 15
    '   If anything falls outside of the range it’s highlighted in yellow.
    Worksheets("BiodataEntryFrm").Range("A1").CurrentRegion.AutoFilter field:=2, Criteria1:="YEP"
    Worksheets("BiodataEntryFrm").Range("A1").CurrentRegion.AutoFilter field:=12, Criteria1:="<.5", Operator:=xlOr, Criteria2:=">15"
    Set rng = Intersect(rng, Worksheets("BiodataEntryFrm").Cells.SpecialCells(xlVisible))
    For Each rngArea In rng.Areas
        For Each rngCell In rngArea.Columns(12).Cells
            If rngCell.Row = 1 Then
            Else
                rngCell.Interior.Color = vbYellow
            End If
        Next
    Next
    Worksheets("BiodataEntryFrm").Range("A1").CurrentRegion.AutoFilter
    Set rng = Worksheets("BiodataEntryFrm").Range("A1").CurrentRegion
    
    Worksheets("BiodataEntryFrm").Range("A1").CurrentRegion.AutoFilter field:=2, Criteria1:="<>YEP"
    Worksheets("BiodataEntryFrm").Range("A1").CurrentRegion.AutoFilter field:=12, Criteria1:="<5", Operator:=xlOr, Criteria2:=">45"
    Set rng = Intersect(rng, Worksheets("BiodataEntryFrm").Cells.SpecialCells(xlVisible))
    For Each rngArea In rng.Areas
        For Each rngCell In rngArea.Columns(12).Cells
            If rngCell.Row = 1 Then
            Else
                rngCell.Interior.Color = vbYellow
            End If
        Next
    Next
    Worksheets("BiodataEntryFrm").Range("A1").CurrentRegion.AutoFilter
    Set rng = Worksheets("BiodataEntryFrm").Range("A1").CurrentRegion
    
    'i.      Check the weight ranges for each species
    '   All but YEP = .1 – 30
    '   YEP = .1 – 2 or 50 to 900
    '   If anything falls outside of the range it’s highlighted in yellow.
    Worksheets("BiodataEntryFrm").Range("A1").CurrentRegion.AutoFilter field:=2, Criteria1:="YEP"
    Worksheets("BiodataEntryFrm").Range("A1").CurrentRegion.AutoFilter field:=13, Criteria1:="<.1", Operator:=xlOr, Criteria2:=">2"
    Worksheets("BiodataEntryFrm").Range("A1").CurrentRegion.AutoFilter field:=13, Criteria1:="<50", Operator:=xlOr, Criteria2:=">900"
    Set rng = Intersect(rng, Worksheets("BiodataEntryFrm").Cells.SpecialCells(xlVisible))
    For Each rngArea In rng.Areas
        For Each rngCell In rngArea.Columns(13).Cells
            If rngCell.Row = 1 Then
            Else
                rngCell.Interior.Color = vbYellow
            End If
        Next
    Next
    Worksheets("BiodataEntryFrm").Range("A1").CurrentRegion.AutoFilter
    Set rng = Worksheets("BiodataEntryFrm").Range("A1").CurrentRegion
    
    Worksheets("BiodataEntryFrm").Range("A1").CurrentRegion.AutoFilter field:=2, Criteria1:="<>YEP"
    Worksheets("BiodataEntryFrm").Range("A1").CurrentRegion.AutoFilter field:=13, Criteria1:="<.1", Operator:=xlOr, Criteria2:=">30"
    Set rng = Intersect(rng, Worksheets("BiodataEntryFrm").Cells.SpecialCells(xlVisible))
    For Each rngArea In rng.Areas
        For Each rngCell In rngArea.Columns(13).Cells
            If rngCell.Row = 1 Then
            Else
                rngCell.Interior.Color = vbYellow
            End If
        Next
    Next
    Worksheets("BiodataEntryFrm").Range("A1").CurrentRegion.AutoFilter
    Set rng = Worksheets("BiodataEntryFrm").Range("A1").CurrentRegion
    
    'j.      Check that for each date there is only one number listed for site and grid.
    'k.      If there are mixed sites and grids within a date – highlight in yellow that whole chunk of data.
    dicUnique.RemoveAll
    For Each rngCell In rng.Columns(3).Cells
        If rngCell.Row = 1 Then
        Else
            If dicUnique.exists(CDate(Int(rngCell.Value)) & "|" & rngCell.Offset(0, 1).Value & "|" & rngCell.Offset(0, 2).Value) Then
                dicUnique(CDate(Int(rngCell.Value)) & "|" & rngCell.Offset(0, 1).Value & "|" & rngCell.Offset(0, 2).Value) = dicUnique(CDate(Int(rngCell.Value)) & "|" & rngCell.Offset(0, 1).Value & "|" & rngCell.Offset(0, 2).Value) + 1
            Else
                dicUnique.Add CDate(Int(rngCell.Value)) & "|" & rngCell.Offset(0, 1).Value & "|" & rngCell.Offset(0, 2).Value, 1
            End If
        End If
    Next
    varItem = dicUnique.keys
    dtPrior = Split(varItem(0), "|")(0)
    For lngLoop = 1 To UBound(varItem)
        dtNext = Split(varItem(lngLoop), "|")(0)
        If dtPrior = dtNext Then
            'highlight the block
            Set rngFind = rng.Columns(3).Find(what:=Format(dtPrior, "mm/dd/yyyy"), LookIn:=xlValues, lookat:=xlPart)
            Do
                Worksheets("BiodataEntryFrm").Range(rngFind, rngFind.Offset(0, 2)).Interior.Color = vbYellow
                Set rngFind = rngFind.Offset(1)
            Loop Until rngFind.Text <> dtPrior
        End If
        dtPrior = dtNext
    Next
    
    'l.      Check scale field
    '   If species = YEP or WAE, scale = spine
    '   If species = COS, BUR, FAT, SMT, scale should be = none
    '   If species = LAT, sites = between 160 and 197, scale = none
    '   Everything else, scale = scale
    '   Anything that falls outside of those rules should be highlighted in yellow.
    Worksheets("BiodataEntryFrm").Range("A1").CurrentRegion.AutoFilter field:=2, Criteria1:="YEP", Operator:=xlOr, Criteria2:="WAE"
    Worksheets("BiodataEntryFrm").Range("A1").CurrentRegion.AutoFilter field:=16, Criteria1:="<>Spine"
    Set rng = Intersect(rng, Worksheets("BiodataEntryFrm").Cells.SpecialCells(xlVisible))
    For Each rngArea In rng.Areas
        For Each rngCell In rngArea.Columns(16).Cells
            If rngCell.Row = 1 Then
            Else
                rngCell.Interior.Color = vbYellow
            End If
        Next
    Next
    Worksheets("BiodataEntryFrm").Range("A1").CurrentRegion.AutoFilter
    Set rng = Worksheets("BiodataEntryFrm").Range("A1").CurrentRegion
    
    For Each varItem In Array("COS", "BUR", "FAT", "SMT")
        Worksheets("BiodataEntryFrm").Range("A1").CurrentRegion.AutoFilter field:=2, Criteria1:=varItem
        Worksheets("BiodataEntryFrm").Range("A1").CurrentRegion.AutoFilter field:=16, Criteria1:="<>None"
        Set rng = Intersect(rng, Worksheets("BiodataEntryFrm").Cells.SpecialCells(xlVisible))
        For Each rngArea In rng.Areas
            For Each rngCell In rngArea.Columns(16).Cells
                If rngCell.Row = 1 Then
                Else
                    rngCell.Interior.Color = vbYellow
                End If
            Next
        Next
        Worksheets("BiodataEntryFrm").Range("A1").CurrentRegion.AutoFilter
        Set rng = Worksheets("BiodataEntryFrm").Range("A1").CurrentRegion
    Next

    Worksheets("BiodataEntryFrm").Range("A1").CurrentRegion.AutoFilter field:=2, Criteria1:="LAT"
    Worksheets("BiodataEntryFrm").Range("A1").CurrentRegion.AutoFilter field:=4, Criteria1:=">=160", Operator:=xlOr, Criteria2:="<=190"
    Worksheets("BiodataEntryFrm").Range("A1").CurrentRegion.AutoFilter field:=16, Criteria1:="<>None"
    Set rng = Intersect(rng, Worksheets("BiodataEntryFrm").Cells.SpecialCells(xlVisible))
    For Each rngArea In rng.Areas
        For Each rngCell In rngArea.Columns(16).Cells
            If rngCell.Row = 1 Then
            Else
                rngCell.Interior.Color = vbYellow
            End If
        Next
    Next
    Worksheets("BiodataEntryFrm").Range("A1").CurrentRegion.AutoFilter
    Set rng = Worksheets("BiodataEntryFrm").Range("A1").CurrentRegion
    
    Set wks = ActiveWorkbook.Worksheets.Add
    wks.Range("a1:b1").Value = Array("Spp", "Site", "Site")
    wks.Range("a2").Value = "YEP"
    wks.Range("a3").Value = "WAE"
    wks.Range("a4").Value = "COS"
    wks.Range("a5").Value = "BUR"
    wks.Range("a6").Value = "FAT"
    wks.Range("a7").Value = "SMT"
    wks.Range("a8").Value = "LAT"
    wks.Range("b8").Value = ">=160"
    wks.Range("c8").Value = "<=197"
    Worksheets("BiodataEntryFrm").Range("A1").CurrentRegion.AdvancedFilter action:=xlFilterInPlace, criteriarange:=wks.Range("A1").CurrentRegion
    For Each rngCell In rng.Columns(16).Cells
        If rngCell.Row = 1 Then
        Else
            If rngCell.EntireRow.Hidden Then
                If rngCell.Value <> "Scale" Then
                    rngCell.Interior.Color = vbYellow
                End If
            End If
        End If
    Next
    Application.DisplayAlerts = False
    wks.Delete
    Application.DisplayAlerts = True
    Worksheets("BiodataEntryFrm").Range("A1").CurrentRegion.AdvancedFilter action:=xlFilterInPlace
    
    Worksheets("BiodataEntryFrm").Range("A:C").Insert
    'n.      Insert a new column in A = “site” (three digits) & “year” (last two digits only) & “no” (four digits) & “-“ & “species”. Label column “New_biodata_ID”.
    'new A
    Worksheets("BiodataEntryFrm").Range("A1").Value = "New_biodata_ID"
    Worksheets("BiodataEntryFrm").Range("A2").Formula = "=Text(G2, ""000"") & Year(F2) & Text(D2, ""0000"") & ""-"" & E2"
    
    'o.      Insert a new column in B = to column about without the “-“ & species. Label new column Old_biodata_ID
    'new B
    Worksheets("BiodataEntryFrm").Range("B1").Value = "Old_biodata_ID"
    Worksheets("BiodataEntryFrm").Range("B2").Formula = "=Text(G2, ""000"") & Year(F2) & Text(D2, ""0000"")"
    
    'p.      Insert a third column, labeled “type” insert the word “BIO” for all records in that field.
    'new C
    Worksheets("BiodataEntryFrm").Range("C1").Value = "type"
    Worksheets("BiodataEntryFrm").Range("C2").Value = "BIO"
    
    Set rngRow = Worksheets("BiodataEntryFrm").Rows(rng.Rows.Count)
    Set rngRow = rngRow.Range(Cells(1, 1), Cells(1, 3))
    Worksheets("BiodataEntryFrm").Range(rngRow.End(xlUp), rngRow).FillDown
    
    'q.      Insert a new column after weight called R/D.
    Set rngFind = Worksheets("BiodataEntryFrm").Range("1:1").Find("Sex")
    Worksheets("BiodataEntryFrm").Columns(rngFind.Column).Insert
    rngFind.Offset(0, -1).Value = "R/D"
    
    Application.ScreenUpdating = True      'reset
End Sub

Open in new window

ASKER CERTIFIED SOLUTION

aikimark

membership

Create a free account to see this answer

Signing up is free and takes 30 seconds. No credit card required.

See answer

Coaster_brook_trout

ASKER

I keep getting the error "subscript out of range"

aikimark

1. where does the error occur?
2. what does your worksheet look like?

Coaster_brook_trout

ASKER

I'll attach it.
FINAL-Oct-Bays-de-Noc-biodata.xls

aikimark

you changed the name of your worksheet.

Replace "BiodataEntryFrm" with "Sanville BiodataEntryFrm" in the code

or rename the worksheet to "BiodataEntryFrm"

aikimark

Also, the code you tested is not the most current.

Coaster_brook_trout

ASKER

It works!!! Thank you so much!!!!

Coaster_brook_trout

ASKER

Thank you so much!!