Customize code for a macro that copies three rows to a new workbook based on a condition

I have some code here which works great. I would like to customize it in a different way though, and have been unsuccessful at doing so and am therefore reaching out to this community. I will try to explain what I would like to do. What the macro does right now: it copies three rows to a new workbook (Rows 4 and 5 as well as the row of the active cell, based on whether the row of the active cell has non-empty cells). What I would like to do is that I would like the macro to copy the following rows to a new workbook:
-Row 4 & 5 (like it's doing right now), but based on whether the below row(s) has(have) non-empty cells.
-any row which i have selected. So instead of just one other row being copied, several other rows should be copied, depending on which rows i select.
To summarize: Assuming I select row 6,8, & 10. When running the macro, a new workbook is created where the following rows have been copied:
-Row 4 & 5
-Row 6,8, & 10 *The condition being however that only those columns are copied where Row 6,8, & 10 are non-empty.
Assuming I select row 14, 54, 31, 64, 65. When running the macro, a new workbook is created where the following rows have been copied:
-Row 4 & 5
-Row 14, 54, 31, 64, 65 *The condition being however that only those columns are copied where Row 14,54,31,64 & 65 are non-empty.
The overall logic of the current code thus doesn't change. Rather, what changes is that I would like to be able to copy several rows apart from 4&5 instead of just one other (as it is doing now-based on where the active cell is)
Here is the code, I hope I have been clear. If anyone has any idea where i could start/how i could do this, please let me know, thanks!!

Public Sub pub_sub_ExportRows()


'#
'# declare private variables
'#
Dim pvt_xls_Current As Excel.Worksheet
Dim pvt_wbk_New As Excel.Workbook
Dim pvt_lng_SelectedSourceRow As Long
Dim pvt_flg_ValidRow As Boolean
Dim pvt_lng_RowNumber As Long
Dim pvt_lng_FirstColumn As Long
Dim pvt_lng_LastColumn As Long
Dim pvt_lng_ColumnNumber As Long
Dim pvt_lng_TargetColumn As Long

'#
'# record the current row based on the active cell
'#
Set pvt_xls_Current = ThisWorkbook.ActiveSheet
pvt_lng_SelectedSourceRow = ActiveCell.Row

'#
'# the maximum number of columns to be considered is not dependent on the columns defined in the
'# worksheet, but rather by a limit imposed by the user - i.e. column HG is the last column to be copied,
'# and column Q is the first column to be considered
'#
pvt_lng_FirstColumn = Columns("Q").Column
pvt_lng_LastColumn = Columns("HG").Column
pvt_lng_TargetColumn = 0

'#
'# check if the selected row is valid by examining the values in the columns on that
'# row - any non-blank value implies that the selected row is valid - when looking at
'# the values the search starts in column Q as requested by the user
'#
With pvt_xls_Current
pvt_flg_ValidRow = False
For pvt_lng_ColumnNumber = pvt_lng_FirstColumn To pvt_lng_LastColumn
If LenB(.Cells(pvt_lng_SelectedSourceRow, pvt_lng_ColumnNumber).Value) > 0 Then
pvt_flg_ValidRow = True
Exit For
End If
Next pvt_lng_ColumnNumber
End With

If Not pvt_flg_ValidRow Then
MsgBox "You must select a valid - i.e. non empty - row"
Exit Sub
End If

If pvt_lng_SelectSourceRow > 10000 Then
MsgBox "You may not select a row > 10000"
Exit Sub
End If

'#
'# create a new workbook to hold the copied values and copy & paste the information to the
'# newly created workbook
'#
Set pvt_wbk_New = Application.Workbooks.Add
With pvt_xls_Current
For pvt_lng_ColumnNumber = pvt_lng_FirstColumn To pvt_lng_LastColumn

If LenB(.Cells(pvt_lng_SelectedSourceRow, pvt_lng_ColumnNumber).Value) > 0 And _
InStr(1, "$AF,$BF,$CG,$DH,$ES,$FV,$HD, $HF", Split(Columns(pvt_lng_ColumnNumber).Address, ":")(0)) = 0 Then
pvt_lng_TargetColumn = pvt_lng_TargetColumn + 1
pvt_wbk_New.Worksheets("Sheet1").Cells(1, pvt_lng_TargetColumn).Value = .Cells(4, pvt_lng_ColumnNumber).Value
pvt_wbk_New.Worksheets("Sheet1").Cells(2, pvt_lng_TargetColumn).Value = .Cells(5, pvt_lng_ColumnNumber).Value
pvt_wbk_New.Worksheets("Sheet1").Cells(3, pvt_lng_TargetColumn).Value = .Cells(pvt_lng_SelectedSourceRow, pvt_lng_ColumnNumber).Value
End If

Next pvt_lng_ColumnNumber
End With


'#
'# activate the new workbook
'#
pvt_wbk_New.Activate
pvt_wbk_New.Worksheets("Sheet1").Cells(1, pvt_lng_TargetColumn).EntireRow.Columns.AutoFit

End Sub

Links for cross-posts:
http://stackoverflow.com/questions/1...k-based-on-a-c
http://www.ozgrid.com/forum/showthread.php?t=173353

hi

please take a moment to read the forum rules again paying special attention to #3 and #8 and then amend your post accordingly. thank you ;-)

you don't have to delete it you just need to add links here to your cross-posts in other forums

you don't. you have a short time to edit them (10 minutes I think) but that's it

Hi Philips,

I do not have the time to do it right now, but I will make the changes tomorrow morning, unless somebody else delivers the change quicker

Ok, this should work

Please add the Microsoft Scripting Runtime reference to your project to allow for early binding of dictionary objects

'#################################################################################################################################
'# requires microsoft scripting runtime
'#################################################################################################################################
     Public Sub pub_sub_ExportRows()

     '#
     '# declare private variables
     '#
          Dim pvt_xls_Current As Excel.Worksheet
          Dim pvt_rng_Current As Excel.Range
          Dim pvt_lng_AreaNumber As Long
          
          Dim pvt_lng_FirstColumn As Long
          Dim pvt_lng_LastColumn As Long
          Dim pvt_flg_ValidRow As Boolean
          Dim pvt_flg_ValidSelection As Boolean
          Dim pvt_lng_RowNumber As Long
          Dim pvt_lng_ColumnNumber As Long
          
          Dim pvt_dct_ValidColumn As Scripting.Dictionary
          Dim pvt_dct_ValidRow As Scripting.Dictionary
          Dim pvt_int_ColumnElement As Integer
          Dim pvt_int_RowElement As Integer
          
          Dim pvt_wbk_New As Excel.Workbook
          Dim pvt_lng_TargetColumn As Long
          Dim pvt_lng_TargetRow As Long
          
     '#
     '# initialise
     '#
          Set pvt_xls_Current = ThisWorkbook.ActiveSheet
          Set pvt_rng_Current = Selection
          
          Set pvt_dct_ValidRow = New Scripting.Dictionary
          Set pvt_dct_ValidColumn = New Scripting.Dictionary
          
          pvt_flg_ValidSelection = False
          
     '#
     '# the maximum number of columns to be considered is not dependent on the columns defined in the
     '# worksheet, but rather by a limit imposed by the user - i.e. column HG is the last column to be copied,
     '# and column Q is the first column to be considered
     '#
          pvt_lng_FirstColumn = Columns("Q").Column
          pvt_lng_LastColumn = Columns("HG").Column
          
     '#
     '# identify all rows in the user selection and add the rows to the valid row dictionary with an
     '# indication that the row is invalid - only when later one or more filled cells are found for the
     '# row in question will the status be changed to valid
     '#
          For pvt_lng_AreaNumber = 1 To pvt_rng_Current.Areas.Count
               For pvt_lng_RowNumber = pvt_rng_Current.Areas(pvt_lng_AreaNumber).Row To (pvt_rng_Current.Areas(pvt_lng_AreaNumber).Row + pvt_rng_Current.Areas(pvt_lng_AreaNumber).Rows.Count - 1)
                    pvt_dct_ValidRow.Add pvt_lng_RowNumber, "INVALID"
               Next pvt_lng_RowNumber
          Next pvt_lng_AreaNumber
               
     '#
     '# for all rows in the selection a check is performed to see if one or more non-empty cells are found -
     '# when found the column is valid for the copy step and the row is valid because one or more non-blank cells were found
     '#
          With pvt_xls_Current
               For pvt_int_RowElement = 0 To (pvt_dct_ValidRow.Count - 1)

               '#
               '# initialise row variables for the current row of the selected area
               '#
                    pvt_flg_ValidRow = False
                    pvt_lng_RowNumber = pvt_dct_ValidRow.Keys(pvt_int_RowElement)
               
               '#
               '# loop for all columns between Q and HG, skipping the columns that should be ignored as per the requirements -
               '# if the cell is not empty then the column is valid and should be included in the copy step, and the row is also
               '# considered valid (non-blank) because a valid entry has been found
               '#
                    For pvt_lng_ColumnNumber = pvt_lng_FirstColumn To pvt_lng_LastColumn
                         If InStr(1, "$AF,$BF,$CG,$DH,$ES,$FV,$HD, $HF,", Split(Columns(pvt_lng_ColumnNumber).Address, ":")(0) & ",") = 0 Then
                              If LenB(.Cells(pvt_lng_RowNumber, pvt_lng_ColumnNumber).Value) > 0 Then
                                   pvt_flg_ValidRow = True
                                   If Not pvt_dct_ValidColumn.Exists(pvt_lng_ColumnNumber) Then
                                        pvt_dct_ValidColumn.Add pvt_lng_ColumnNumber, "VAL"
                                   End If
                              End If
                         End If
                    Next pvt_lng_ColumnNumber
                    
               '#
               '# if one or more non-empty cells were encountered for the current row, the row is considered a valid
               '# row for the copy step, if not a message is presented to the user
               '#
                    If pvt_flg_ValidRow Then
                         pvt_dct_ValidRow(pvt_int_RowElement) = "VALID"
                         pvt_flg_ValidSelection = True
                    Else
                         MsgBox "Row number " & pvt_lng_RowNumber & " is skipped as all cells are empty"
                    End If
                    
               Next pvt_int_RowElement
          End With
          
     '#
     '# if no rows have been selected
     '#
          If Not pvt_flg_ValidSelection Then
               MsgBox "No valid rows selected, no new workbook created"
               Exit Sub
          End If
          
     '#
     '# the dictionary objects now hold all valid columns and all valid rows that should be included in the
     '# copy workbook - create the new workbook and copy the data
     '#
          Set pvt_wbk_New = Application.Workbooks.Add
          pvt_lng_TargetRow = 0
          
          With pvt_xls_Current
          
          '#
          '# always create the header rows
          '#
               For pvt_lng_RowNumber = 4 To 5
                    pvt_lng_TargetColumn = 0
                    pvt_lng_TargetRow = pvt_lng_TargetRow + 1
                    For pvt_int_ColumnElement = 0 To (pvt_dct_ValidColumn.Count - 1)
                         pvt_lng_TargetColumn = pvt_lng_TargetColumn + 1
                         pvt_wbk_New.Worksheets("Sheet1").Cells(pvt_lng_TargetRow, pvt_lng_TargetColumn).Value = _
                              .Cells(pvt_lng_RowNumber, pvt_dct_ValidColumn.Keys(pvt_int_ColumnElement)).Value
                    Next pvt_int_ColumnElement
               Next pvt_lng_RowNumber
                    
          '#
          '# now loop for all valid rows as stored in the dictionary - and per row copy the valid columns again
          '# from the dictionary
          '#
               For pvt_int_RowElement = 0 To (pvt_dct_ValidRow.Count - 1)
                    If pvt_dct_ValidRow(pvt_int_RowElement) = "VALID" Then
                         pvt_lng_RowNumber = pvt_dct_ValidRow.Keys(pvt_int_RowElement)
                         pvt_lng_TargetRow = pvt_lng_TargetRow + 1
                         pvt_lng_TargetColumn = 0
                         For pvt_int_ColumnElement = 0 To (pvt_dct_ValidColumn.Count - 1)
                              pvt_lng_TargetColumn = pvt_lng_TargetColumn + 1
                              pvt_wbk_New.Worksheets("Sheet1").Cells(pvt_lng_TargetRow, pvt_lng_TargetColumn).Value = _
                                   .Cells(pvt_lng_RowNumber, pvt_dct_ValidColumn.Keys(pvt_int_ColumnElement)).Value
                         Next pvt_int_ColumnElement
                    End If
               Next pvt_int_RowElement
               
          End With

     '#
     '# set all columns in the new workbook to autofit and activate the new workbook
     '#
          With pvt_wbk_New
               .Worksheets("Sheet1").Cells.Columns.AutoFit
               .Activate
          End With
          
End Sub

Philips, I have thought of several improvements so version 2 will follow a bit later. I suggest you wait with testing until I have posted the revised code

Version 2.

Please remember to add a reference to the Microsoft Scripting Runtime

'#################################################################################################################################
'# requires microsoft scripting runtime
'#################################################################################################################################
     Public Sub pub_sub_ExportRows()

     '#
     '# declare private variables
     '#
          Dim pvt_wbk_New As Excel.Workbook
          Dim pvt_xls_Current As Excel.Worksheet
          
          Dim pvt_dct_ValidColumn As Scripting.Dictionary
          Dim pvt_dct_SkipColumn As Scripting.Dictionary
          Dim pvt_dct_ValidRow As Scripting.Dictionary
          
          Dim pvt_lng_AreaNumber As Long
          Dim pvt_lng_FirstColumn As Long
          Dim pvt_lng_LastColumn As Long
          Dim pvt_lng_RowNumber As Long
          Dim pvt_lng_ColumnNumber As Long
          
          Dim pvt_flg_ValidRow As Boolean
          Dim pvt_var_SkipColumn As Variant
          Dim pvt_int_ColumnElement As Integer
          Dim pvt_int_RowElement As Integer
          Dim pvt_lng_TargetColumn As Long
          Dim pvt_lng_TargetRow As Long
          
     '#
     '# initialise variables - note that the maximum number of columns to be considered is not dependent on the
     '# columns defined in the worksheet, but rather by a limit imposed by the user - i.e. from column "Q" to "HG"
     '#
          Set pvt_xls_Current = ThisWorkbook.ActiveSheet
          Set pvt_dct_ValidRow = New Scripting.Dictionary
          Set pvt_dct_ValidColumn = New Scripting.Dictionary
          Set pvt_dct_SkipColumn = New Scripting.Dictionary
          
          pvt_lng_FirstColumn = Columns("Q").Column
          pvt_lng_LastColumn = Columns("HG").Column
          
     '#
     '# load the dictionary of invalid columns based on the columns that were specified as to be
     '# excluded from the copy process - additional column identifiers can be added to the array
     '# as and when needed
     '#
          For Each pvt_var_SkipColumn In Array("AF", "BF", "CG", "DH", "ES", "FV", "HD", "HF")
               pvt_dct_SkipColumn.Add Columns(pvt_var_SkipColumn).Column, vbNullString
          Next pvt_var_SkipColumn
          
     '#
     '# add the header rows 4 and 5 to the valid row dictionary because they always need to be included
     '# in the copy step - as long as at least one valid data rows has been found in the selection
     '#
          pvt_dct_ValidRow.Add 4, vbNullString
          pvt_dct_ValidRow.Add 5, vbNullString
          
     '#
     '# execute a loop on all rows present in the selection - adjacent selected rows are always in a single
     '# area - but more areas can be present in the selection made by the user
     '#
          With pvt_xls_Current
          
               For pvt_lng_AreaNumber = 1 To Selection.Areas.Count
                    For pvt_lng_RowNumber = Selection.Areas(pvt_lng_AreaNumber).Row To (Selection.Areas(pvt_lng_AreaNumber).Row + Selection.Areas(pvt_lng_AreaNumber).Rows.Count - 1)
                    '#
                    '# loop for all columns from Q to HG, skipping the excluded columns, to determine if a non-blank
                    '# entry exists - when found the column must be added to the valid column dictionary and the
                    '# boolean indicating that the row is valid must be set to True
                    '#
                         pvt_flg_ValidRow = False
                         For pvt_lng_ColumnNumber = pvt_lng_FirstColumn To pvt_lng_LastColumn
                              If Not pvt_dct_SkipColumn.Exists(pvt_lng_ColumnNumber) Then
                                   If LenB(.Cells(pvt_lng_RowNumber, pvt_lng_ColumnNumber).Value) > 0 Then
                                        pvt_flg_ValidRow = True
                                        If Not pvt_dct_ValidColumn.Exists(pvt_lng_ColumnNumber) Then
                                             pvt_dct_ValidColumn.Add pvt_lng_ColumnNumber, "VAL"
                                        End If
                                   End If
                              End If
                         Next pvt_lng_ColumnNumber
                    '#
                    '# if a non-blank cell was encountered for the selected row, the row is considered valid
                    '# and the tow number is added to the valid row dictionary object - if not a message
                    '# is displayed to the user stating that the row is skipped
                    '#
                         If pvt_flg_ValidRow Then
                              pvt_dct_ValidRow.Add pvt_lng_RowNumber, vbNullString
                         Else
                              MsgBox "Row number " & pvt_lng_RowNumber & " is skipped as all cells are empty"
                         End If
                    Next pvt_lng_RowNumber
               Next pvt_lng_AreaNumber
          
          End With
          
     '#
     '# if no valid data rows were encountered during the previous step, the valid row collection
     '# only holds the two entries (i.e. the header rows 4 and 5) - inform the user and exit the routine
     '#
          If pvt_dct_ValidRow.Count = 2 Then
               MsgBox "No valid rows selected, no new workbook created"
               Exit Sub
          End If
          
     '#
     '# the dictionary objects now hold all valid columns and all valid rows that should be included in the
     '# copy workbook - create the new workbook and copy the data
     '#
          Set pvt_wbk_New = Application.Workbooks.Add
          pvt_lng_TargetRow = 0
          
          With pvt_xls_Current
               For pvt_int_RowElement = 0 To (pvt_dct_ValidRow.Count - 1)
                    
                    pvt_lng_RowNumber = pvt_dct_ValidRow.Keys(pvt_int_RowElement)
                    pvt_lng_TargetRow = pvt_lng_TargetRow + 1
                    pvt_lng_TargetColumn = 0
                    
                    For pvt_int_ColumnElement = 0 To (pvt_dct_ValidColumn.Count - 1)
                         pvt_lng_TargetColumn = pvt_lng_TargetColumn + 1
                         pvt_wbk_New.Worksheets("Sheet1").Cells(pvt_lng_TargetRow, pvt_lng_TargetColumn).Value = _
                                   .Cells(pvt_lng_RowNumber, pvt_dct_ValidColumn.Keys(pvt_int_ColumnElement)).Value
                    Next pvt_int_ColumnElement
                    
               Next pvt_int_RowElement
          End With

     '#
     '# set all columns in the new workbook to autofit and activate the new workbook
     '#
          With pvt_wbk_New
               .Worksheets("Sheet1").Cells.Columns.AutoFit
               .Activate
          End With
          
End Sub

Philips,

Strange, the code works fine on some sample data that I have compiled myself. Are you sure about the line number in error? Can you see (by hovering your cursor over the variables) what the values are at the moment of the error?

or replace the line with

If .Cells(pvt_lng_RowNumber, pvt_lng_ColumnNumber).Value <> "" Then

Not as nice, but maybe less sensitive to problems in case for formula errors and so on

Philips,

Never mind, it is probably a formula result error or someting

Change the line to:

If Cstr$(.Cells(pvt_lng_RowNumber, pvt_lng_ColumnNumber).Value) <> "" Then

and it should work fine

Ok, getting to the cause of the problem

can you have a look at the contents of row 6 in column HG?

Glad to have been of help. Remember to mark the thread as SOLVED and click the little star if you are happy with my contribution!