Results 1 to 3 of 3
  1. #1
    Star Lounger
    Join Date
    Nov 2003
    Location
    Tampa, Florida, USA
    Posts
    62
    Thanks
    0
    Thanked 0 Times in 0 Posts

    Copy of one worksheet to tw0 other worksheets bas

    I need some VBA code help to finish copying worksheet rows of data from columns "V to Z" to another workbook to two different worksheets depending upon the criteria in column H. The values in the rows on columns V to Z are formulas. The actual values are to be copied.

    While the value in column H is "Y" Copy the row from Column V to Z to workbook GTABT2.xls worksheet NCE range A4. Copy Next Row
    While the value in column H is "N" Copy the row from Column V to Z to workbook
    GTABPT2.xls worksheet NHCE range A4. Copy Next Row
    If the value in column H is neither Y nor N then do nothing

    The following code works except that when column H is "N" the destination paste starts at row 7 instead of row 4
    How do I adjust it to start at row 4




    Sub Row_Transfer()
    Dim WshTgt As Worksheet
    WshSrce As Worksheet
    Set WshTgt = Workbooks("GTABPT2.xls") _
    .Worksheets("HCE")
    Set WshSrce = Workbooks("fit_assessment_allocation_template2.xls ") _
    .Worksheets("scenario 1 -9and3")
    Set WshTgt2 = Workbooks("GTABPT2.xls") _
    .Worksheets("NHCE")
    Dim LRow As Integer
    Dim LRow2 As Integer
    Dim LCell As String
    Dim LColCells As String
    'Start at row 5
    With WshSrce
    LRow = 5
    LRow2 = 4 'Destination start row
    Application.ScreenUpdating = False
    'Update row copy for the first 20 rows
    While LRow < 20
    LCell = "H" & LRow
    'Cells to copy are column V to Z not empty rows
    LColCells = "V" & LRow & ":" & "Z" & LRow

    Select Case Left(Range(LCell).Value, 8)

    'copy Y values to HCE sheet
    Case "Y"
    WshSrce.Range(LColCells).copy
    WshTgt.Cells(LRow2, 1).PasteSpecial xlPasteValues,,False,False

    'copy N values to NHCE Sheet
    Case "N"
    Rows(LRow & ":" & LRow).Select
    WshSrce.Range(LColCells).Copy
    WshTgt2.Cells(LRow2, 1).PasteSpecial xlPasteValues, , False, False

    'do not copy other cells
    Case Else
    Rows(LRow & ":" & LRow).Select
    Range(LColCells).Interior.ColorIndex = xlNone

    End Select
    LRow2 =LRow2 + 1
    LRow = LRow + 1

    Wend
    End With
    Range("A1").Select
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
    End Sub

  2. #2
    Silver Lounger
    Join Date
    Jul 2001
    Location
    Ottawa, Ontario, Canada
    Posts
    1,609
    Thanks
    0
    Thanked 1 Time in 1 Post

    Re: Copy of one worksheet to tw0 other worksheets bas

    If your intent is to past to row 4 then row 5 etc, irrespective of the row which has been copied; then you should use something like the following :

    Option Explicit



    Sub Row_Transfer()
    Dim WshTgt As Worksheet
    Dim WshTgt2 As Worksheet ' Statement added
    Dim WshSrce As Worksheet ' Dim added
    Set WshTgt = Sheets("Sheet2") 'Revised to allow testing on my machine
    Set WshSrce = Sheets("Sheet1") 'Revised to allow testing on my machine
    Set WshTgt2 = Sheets("Sheet3") 'Revised to allow testing on my machine
    Dim LRow As Integer
    Dim LRowY As Integer 'Variable name changed for clarity
    Dim LRowN As Integer 'Variable Added
    Dim LCell As String
    Dim LColCells As String
    'Start at row 5
    With WshSrce
    LRow = 5
    LRowY = 4 'Destination start row
    LRowN = 4 'Destination start row (Added)
    Application.ScreenUpdating = False
    'Update row copy for the first 20 rows
    While LRow < 20
    LCell = "H" & LRow
    'Cells to copy are column V to Z not empty rows
    LColCells = "V" & LRow & ":" & "Z" & LRow

    Select Case Left(Range(LCell).Value, 8)

    'copy Y values to HCE sheet
    Case "Y"
    WshSrce.Range(LColCells).Copy
    WshTgt.Cells(LRowY, 1).PasteSpecial xlPasteValues, , False, False
    LRowY = LRowY + 1 ' Added

    'copy N values to NHCE Sheet
    Case "N"
    Rows(LRow & ":" & LRow).Select
    WshSrce.Range(LColCells).Copy
    WshTgt2.Cells(LRowN, 1).PasteSpecial xlPasteValues, , False, False
    LRowN = LRowN + 1 'Added

    'do not copy other cells
    Case Else
    Rows(LRow & ":" & LRow).Select
    Range(LColCells).Interior.ColorIndex = xlNone

    End Select
    ' LRow2 = LRow2 + 1' No longer used
    LRow = LRow + 1

    Wend
    End With
    Range("A1").Select
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
    End Sub
    Regards
    Don

  3. #3
    Star Lounger
    Join Date
    Nov 2003
    Location
    Tampa, Florida, USA
    Posts
    62
    Thanks
    0
    Thanked 0 Times in 0 Posts

    Re: Copy of one worksheet to tw0 other worksheets

    Don:
    I see that I needed to add the Row increase ( LRowY = LRowY + 1 ) after each Case rather than after the End Select.
    In the meantime I also came up with the following;

    Sub Row_TransferYN()
    Dim WshTgtY As Worksheet, WshTgtN As Worksheet
    Dim rgSource As Range, rw As Range
    Dim LRowY As Long, lRowN As Long
    Dim LCell As String
    Dim LColCells As String

    Set WshTgtY = Workbooks("GTABPT2.xls").Worksheets("HCE")
    Set WshTgtN = Workbooks("GTABPT2.xls").Worksheets("NHCE")
    Set rgSource = Workbooks("fit_assessment_allocation_template2.xls ") _
    .Worksheets("scenario 1 -9and3").Range("V5:Z200")

    Application.ScreenUpdating = False
    LRowY = 4
    lRowN = 4

    For Each rw In rgSource.Rows
    Select Case rw.EntireRow.Cells(1, "H")
    Case "Y"
    WshTgtY.Cells(LRowY, 1).Resize(1, 5).Value = rw.Value
    LRowY = LRowY + 1

    'copy NHCEs to NHCE Sheet
    Case "N"
    WshTgtN.Cells(lRowN, 1).Resize(1, 5).Value = rw.Value
    lRowN = lRowN + 1

    'do not copy other cells
    Case Else
    End Select
    Next
    Application.ScreenUpdating = True
    End Sub
    <img src=/S/bravo.gif border=0 alt=bravo width=16 height=30> Don
    Thanks again. Saved me "hours" of time.and I learned something as well

Posting Permissions

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