Results 1 to 19 of 19

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

Threaded View

  1. #1
    Registered User
    Join Date
    12-21-2012
    Location
    Amsterdam, The Netherlands
    MS-Off Ver
    Excel 2010
    Posts
    24

    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
    Last edited by philips; 01-03-2013 at 10:18 AM.

Thread Information

Users Browsing this Thread

There are currently 1 users browsing this thread. (0 members and 1 guests)

Tags for this Thread

Bookmarks

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts

Search Engine Friendly URLs by vBSEO 3.6.0 RC 1