Modify macro to ignore blanks cells in changing columns to rows - advanced

[Maggie Barr]

Hello there,
I found an amazing macro on this forum by Hiker95 that works perfectly for me except that I would like for it to ignore blank cells within the dataset. I am using a PC with Excel 2010. When I run the macro it gives me what I want, but it also creates rows for cells within the spreadsheet that are blanks, and I would like for it to not create rows for the blank cells. In column A I have the current scientific Latin name of a plant, and in the subsequent columns (B-Q) I have Latin synonymy. I would like Column A to get repeated and Have columns B-Q get put in Column B with the heading of those columns in Column C (Please see sheet 2 of the Box Net file below for example). The Macro gave me Column A repeated to match the synonymy in Column B (from all the other columns), but there are many blanks.
So Sorry for not being able to display the data, I am new to all of this, and I have tried to post examples/screanshots of my data using MrExceHtml, but when I paste it, only a large amount of what look like garble is visible (hopefully I can figure this one out soon).
I have uploaded my file to Box Net: https://app.box.com/s/pdcvamsr9dtm8atsmz6d
In sheet one is the raw data, and in sheet two is the data after the macro was run.
In case the macro doesn't come through as visible in developer through Box Net the macro I ran is below:
Thank you all so much for your time and help, and sorry for my inabilities to post screenshots yet.
Best Wishes,
Maggie

Sub ReorgData()
'   hiker95, 08/04/2014, ME796335
    Dim w1 As Worksheet, w2 As Worksheet
    Dim a As Variant, o As Variant
    Dim i As Long, j As Long
    Dim lr As Long, lc As Long, c As Long, n As Long
    Application.ScreenUpdating = False
    Set w1 = Sheets("Sheet1")
    Set w2 = Sheets("Sheet2")
    With w1
        lr = .Cells(Rows.Count, 1).End(xlUp).Row
        lc = .Cells(1, Columns.Count).End(xlToLeft).Column
        a = .Range(.Cells(1, 1), .Cells(lr, lc))
        n = ((lr - 1) * (lc - 1)) + 1
        ReDim o(1 To n, 1 To 3)
    End With
    j = j + 1
    o(j, 1) = "Name"
    o(j, 2) = "value"
    o(j, 3) = "Yr"
    For i = 2 To lr
        For c = 2 To lc
            j = j + 1
            o(j, 1) = a(i, 1)
            o(j, 2) = a(i, c)
            o(j, 3) = Right(a(1, c), Len(a(1, c)) - 2)
        Next c
    Next i
    With w2
        .UsedRange.ClearContents
        .Cells(1, 1).Resize(n, 3).Value = o
        .Columns(1).Resize(, 3).AutoFit
        .Activate
    End With
    Application.ScreenUpdating = True
End Sub

 

[Maggie Barr]

Hiker,
It would be great if you could take the time to explain the details of the macro to me. Thank you as well for the list of reference materials. It is difficult to put hours in for work and still have time for skill development, but I am gaining bits and pieces all the time. I have to say that this stuff is just too cool. I find myself reading through Mr. Excel posts as if it were social media (not really into social media). My boss tells me that is not "normal", and I laugh because he is someone that would do the same, but he is into reading scientific journals for entertainment.
Anyway, thanks for everything, and if you are interested, here is a link to my most recent puzzle/thread.
http://www.mrexcel.com/forum/excel-...tiple-columns-data-new-sheet.html#post3926290
Best Wishes,
Maggie

 

[hiker95]

Maggie Barr,

It would be great if you could take the time to explain the details of the macro to me.

I will be back a little later with comments added to the macro code to explain what is going on to solve your request.

Thank you as well for the list of reference materials. It is difficult to put hours in for work and still have time for skill development, but I am gaining bits and pieces all the time. I have to say that this stuff is just too cool.

You are very welcome.

See the last part of the list entitled:

And, as your skills increase, try answering threads on sites like:

if you are interested, here is a link to my most recent puzzle/thread

Will also check your new thread later.

 

[hiker95]

Maggie Barr,

I hope that the alignment works correctly.


See all the comments that begin with the ' character in the below macro code:

'   the following is the macro name
'   ReorgData_NoBlanks
Sub ReorgData_NoBlanks()



' the following is for my own record keeping
'          the date of the macro
'          |             the MrExcel thread number
'          |             |
'          |             |
'                        |
' hiker95, 09/02/2014, ME802529



' I define all the variables that will be used in the macro.
'    this is a good programming practice, just in case there is a problem
'    with the macro code, another programmer should be able to help
'   w1 will stand for Sheet1
'                    w2 will stand for Sheet2
Dim w1 As Worksheet, w2 As Worksheet



' Variant arrays can hold all types of information
'   the
'   a array will hold all the informaton in Sheet1
'                 o stands for the output array
'                 o array will hold all the information
'                     that will be written to Sheet2
Dim a As Variant, o As Variant



'   i is the row counter for the a array
'              j is the row counter for the o array
Dim i As Long, j As Long



'   lr = last row, what is the last row used in Sheet1 column A
'               lc = last column, what is the last used column in row 1
'                           c is the loop counter for columns 2 = B, to lc = Q
'                                      n counts how many cells contain data
'                                        in Range("B2:Q" & lr)
Dim lr As Long, lc As Long, c As Long, n As Long



' turn off screen updating - the macro will run faster
Application.ScreenUpdating = False



' set w1 to Sheet1, and, w2 to Sheet2
Set w1 = Sheets("Sheet1")
Set w2 = Sheets("Sheet2")



'  we are starting to work in w1 = Sheet1
With w1



' find the last used row
'                      in 1 = column A
  lr = .Cells(Rows.Count, 1).End(xlUp).Row
  
  
  
' find the last used column in
'         row 1
  lc = .Cells(1, Columns.Count).End(xlToLeft).Column



' create the
' a array from Range("A1:Q" & lr)
'             A1            Q     lr
  a = .Range(.Cells(1, 1), .Cells(lr, lc))
  
  

' n counts how many cells contain data
'                      in Range("B2:Q" & lr)
  n = Application.CountA(.Range(.Cells(2, 2), .Cells(lr, lc)))
  
  
  
' create the o array
'         rows
'         1 to n + 1
'                     columns
'                     1 to 3
  ReDim o(1 To n + 1, 1 To 3)
End With



' j right now = 0
' j = j + 1
' j now is 1
j = j + 1



' fill in the o array titles
o(j, 1) = "Current Name"
o(j, 2) = "Synonym"
o(j, 3) = "Synonym #"



' loop thru the a array beginning in row
'       2
'            to the last row
For i = 2 To lr



' loop thru the columns from column
'         2 to the lc
  For c = 2 To lc Step 1
  
  
  
'   if a(i, c) is not equal to a blank
    If a(i, c) <> "" Then
    
    
    
'     increment the o array row counter j by 1
      j = j + 1


'     for Sheet1, row 2
'     o(j, 1) = "Abies balsamea"
      o(j, 1) = a(i, 1)



'     o(j, 2) = "Abies balsamea var. phanerolepis"
      o(j, 2) = a(i, c)


'     o(j, 3) = "nonymy 1 WITHOUT authors"
      o(j, 3) = "nonymy " & c - 1 & " WITHOUT authors"
    End If



' loop to the next column until the last column is reached
  Next c



' then increment the a array row counter by 1
'   and process all the non blank cells as above
Next i



'  we are starting to work in w2 = Sheet2
With w2



'  clear the used range in the the worksheet
  .UsedRange.ClearContents



'  write to
'  Range("A1:C" n + 1)
'                                       the contents of the
'                                       o array
  .Cells(1, 1).Resize(n + 1, 3).Value = o



'  autofit all the columns
  .Columns.AutoFit
  
  
  
'  Activate w2 = Sheet2
  .Activate
End With



' turn on screen updating
Application.ScreenUpdating = True
End Sub

 

[hiker95]

Maggie Barr,

I see that MickG has you covered with your new thread - you are in very good hands.