"Read" the column header "Element" and perform calculation

**dwsf** · 09-14-2015, 12:25 AM

Hello VBA Gurus,

I get outputs from a program that gives me values in mol but I want mg.
The column headers could be any order and any length and contain red-herrings (things that are not elements).
I am trying to build a macro that searches the column header, identifies which element (if any) it refers to, then performs the appropriate conversion to all the values in that column (which may be of any length), then moves on to the next column.

I have a collection of the elements and their atomic masses but I am stuck in the weeds manipulating collections and arrays.

Attached is example input file.

I want to multiply each value in the column by the corresponding atomic mass and then by 1000.

Here is my code (I haven't got very far!):


Sub elementLookup()

Dim rngElementHeader As Range
Dim rngHeaders As Range
Dim Element As String
Set rngHeaders = Range("1:1")
Set rngElementHeader = rngHeaders.Find(Element)
Dim x As Long, y As Long
Elements = Array("H", "He", "Li", "Be", "B", "C", "N", "O", "F", "Ne", "Na", "Mg", "Al", "Si", "P", "S", "Cl", "Ar", "K", "Ca", "Sc", "Ti", "V", "Cr", "Mn", "Fe", "Co", "Ni", "Cu", "Zn", "Ga", "Ge", "As", "Se", "Br", "Kr", "Rb", "Sr", "Y", "Zr", "Nb", "Mo", "Ru", "Rh", "Pd", "Ag", "Cd", "In", "Sn", "Sb", "Te", "I", "Xe", "Cs", "Ba", "La", "Ce", "Pr", "Nd", "Sm", "Eu", "Gd", "Tb", "Dy", "Ho", "Er", "Tm", "Yb", "Lu", "Hf", "Ta", "W", "Re", "Os", "Ir", "Pt", "Au", "Hg", "Tl", "Pb", "Bi")


For Each Element In Elements

x = Rows(1).Find(Element, LookIn:=xlValues, lookat:=xlWhole).Column
currentelementmass = c.Item(Element)

Dim c As Collection

Set c = New Collection

c.Add "1.00794", "H"
c.Add "4.002602", "He"
c.Add "6.941", "Li"
c.Add "9.012182", "Be"
c.Add "10.811", "B"
c.Add "12.011", "C"
c.Add "14.00674", "N"
c.Add "15.9994", "O"
c.Add "18.9984032", "F"
c.Add "20.1797", "Ne"
c.Add "22.989768", "Na"
c.Add "24.305", "Mg"
c.Add "26.981539", "Al"
c.Add "28.0855", "Si"
c.Add "30.973762", "P"
c.Add "32.066", "S"
c.Add "35.4527", "Cl"
c.Add "39.948", "Ar"
c.Add "39.0983", "K"
c.Add "40.078", "Ca"
c.Add "44.95591", "Sc"
c.Add "47.88", "Ti"
c.Add "50.9415", "V"
c.Add "51.9961", "Cr"
c.Add "54.93805", "Mn"
c.Add "55.847", "Fe"
c.Add "58.9332", "Co"
c.Add "58.6934", "Ni"
c.Add "63.546", "Cu"
c.Add "65.39", "Zn"
c.Add "69.723", "Ga"
c.Add "72.61", "Ge"
c.Add "74.92159", "As"
c.Add "78.96", "Se"
c.Add "79.904", "Br"
c.Add "83.8", "Kr"
c.Add "85.4678", "Rb"
c.Add "87.62", "Sr"
c.Add "88.90585", "Y"
c.Add "91.224", "Zr"
c.Add "92.90638", "Nb"
c.Add "95.94", "Mo"
c.Add "101.07", "Ru"
c.Add "102.9055", "Rh"
c.Add "106.42", "Pd"
c.Add "107.8682", "Ag"
c.Add "112.411", "Cd"
c.Add "114.818", "In"
c.Add "118.71", "Sn"
c.Add "121.757", "Sb"
c.Add "127.6", "Te"
c.Add "126.90447", "I"
c.Add "131.29", "Xe"
c.Add "132.90543", "Cs"
c.Add "137.327", "Ba"
c.Add "138.9055", "La"
c.Add "140.115", "Ce"
c.Add "140.90765", "Pr"
c.Add "144.24", "Nd"
c.Add "150.36", "Sm"
c.Add "151.965", "Eu"
c.Add "157.25", "Gd"
c.Add "158.92534", "Tb"
c.Add "162.5", "Dy"
c.Add "164.93032", "Ho"
c.Add "167.26", "Er"
c.Add "168.93421", "Tm"
c.Add "173.04", "Yb"
c.Add "174.967", "Lu"
c.Add "178.49", "Hf"
c.Add "180.9479", "Ta"
c.Add "183.84", "W"
c.Add "186.207", "Re"
c.Add "190.23", "Os"
c.Add "192.22", "Ir"
c.Add "195.08", "Pt"
c.Add "196.96654", "Au"
c.Add "200.59", "Hg"
c.Add "204.3833", "Tl"
c.Add "207.2", "Pb"
c.Add "208.98037", "Bi"




End Sub

Thanks in advance, I have been using this site for a long time and it's a great thing!

**Leith Ross** · 09-14-2015, 01:14 AM

Hello dwsf,

Welcome to the Forum!

There is a problem with the Excel file you attached. I am unable to open it. Please upload the file again and be sure your extension is correct for the version of Excel you are using.

**dwsf** · 09-14-2015, 01:24 AM

Hi Leith,
Thanks for the welcome- hopefully attachment works this time, it was a CSV previously so that might have been a problem.
Dave

**Leith Ross** · 09-14-2015, 01:26 AM

Hello dwsf,

Thanks for uploading the file again. Now it opens with no problems.

**Leith Ross** · 09-14-2015, 09:19 PM

Hello dwsf,

I didn't forget about you. It was late night, my time, when I replied. I was out all day today.

This macro uses a Dictionary object instead of a collection. The Dictionary has several added features that Collections don't have but I won't go into to detail about that here.

The attached workbook has a second sheet added to it named "Elem Data". This is a listing of the elements and their masses. This is easier to update than a long array in your macro. A range's values can be read vary easily and quickly into an array using the macro. In the long run, this will make your life easier.

I have annotated the macro to help you better understand what it is doing. Using arrays to manipulate Excel data is always faster than going cell by cell. Turning off screen updating helps speed up the macro as the screen is updated only once after all values have been updated. This also eliminates screen flicker.

Here is the macro that has been added to the attached workbook...

Sub Macro1()

    Dim col     As Long
    Dim Data    As Variant
    Dim Dict    As Object
    Dim Key     As String
    Dim Item    As Variant
    Dim Mass    As Double
    Dim Rng     As Range
    Dim row     As Long
    Dim Wks1    As Worksheet
    Dim Wks2    As Worksheet

        Set Dict = CreateObject("Scripting.Dictionary")
          ' Make Dictionary key matching case insensitive.
            Dict.CompareMode = vbTextCompare
        
        Set Wks2 = Worksheets("Elem Data")
        Set Wks1 = Worksheets("HV test3")
        
          ' Load the Dictionary object with Key/Item pairs.
            Set Rng = Wks2.Range("A1").CurrentRegion
              ' Row one contains column headers.
                For row = 2 To Rng.Rows.Count
                  ' Value in Column "A" is the Key and the value in Column "B" is the Item.
                    Key = Trim(Rng.Cells(row, 1).Value)
                    Item = Rng.Cells(row, 2).Value
                    If Not Dict.Exists(Rng.Cells(row, 1).Value) Then
                        Dict.Add Key, Item
                    End If
                Next row
                
            Application.ScreenUpdating = Flase
            
          ' Convert columns that match elements on "Elem Data" worksheet.
            Set Rng = Wks1.Range("A1").CurrentRegion
                For col = 1 To Rng.Columns.Count
                  ' Remove any leading or trailing spaces from the dictionary key (Element).
                    Key = Trim(Rng.Cells(1, col))
                  ' Check if the element exists.
                    If Dict.Exists(Key) Then
                      ' Get the atomic mass for this element.
                        Mass = Dict(Key)
                      ' Copy the column's cell values into an array.
                        Data = Rng.Columns(col).Cells.Value
                          ' Multipy each element by the mass and again by 1000.
                            For row = 2 To Rng.Rows.Count
                                Data(row, 1) = Data(row, 1) * Mass * 1000
                            Next row
                      ' Copy the updated values back to the column's cells.
                        Rng.Columns(col).Cells.Value = Data
                    End If
                Next col
                
            Application.ScreenUpdating = True
                
End Sub

**dwsf** · 09-14-2015, 10:21 PM

Hi Leith,

This is fantastic! Thank you so much!

I have created the dictionary in VBA using the Dict.add "element","Key" and set it to operate on the first sheet (which will always be the sheet of concern) so that it's a stand-alone solution-in-a-macro.

It's exactly the solution I've been seeking and it will drastically reduce the tedium in my life.

I really appreciate the annotations to help me with my understanding.

This forum is a great resource due to its knowledgeable and altruistic contributors, thanks!

**Leith Ross** · 09-15-2015, 01:41 AM

Hello dwsf,

You're welcome. Glad I could help you solve this problem.

"Read" the column header "Element" and perform calculation

LinkBack

Thread Tools

Rate This Thread

Display

Hybrid View

"Read" the column header "Element" and perform calculation

Re: "Read" the column header "Element" and perform calculation

Re: "Read" the column header "Element" and perform calculation

Re: "Read" the column header "Element" and perform calculation

Re: "Read" the column header "Element" and perform calculation

Re: "Read" the column header "Element" and perform calculation

Re: "Read" the column header "Element" and perform calculation

Thread Information

Users Browsing this Thread

Similar Threads

[SOLVED] Replace all BLANK cells in column with header title "Balance" to "0"

Don't know the Forumlas with problem either using "vlookup" "if" "and" or "index" "match"

[SOLVED] How to USE """"" cells count """"" change font color

[SOLVED] If there is any text in column "A$" on "sheet1" then move cell to column "A$" on "sheet2"

Pivot Table - How to "add a data column" "of the same field" "across multiple sheets"

[SOLVED] Formula needed to display "Pass" or "Fail" if a column contains any values other than "yes

Count the unique items in column F if E:E = "Chris" and M:M = "VIC" and N:N = "PT"

How to pull info in column "C" when "A" & "B" match certain criteria

Tags for this Thread

Bookmarks

Bookmarks

Posting Permissions