none
Copy row and past in another sheet RRS feed

  • Question

  • Hello folks, I need a help to finish this code.. I would like to take all the cases "closed" in my worksheet and send to another sheet(Database) to create some views after. I worked a lot with excel and access, with both I could do that easily, but I am studying VBA now and trying to create that... Could you help me please? Thank you!!

    Sub exportdatabase()

    Range("J1").Select
     
    countline = 1
    checkcell = Cells(countline, 1).Value
    While checkcell = "Closed"

    If checkcell = "Closed" Then

    Rows(checkcell.Row).Select
    Rows(checkcell.Row).Cut

    Sheets("Database").Select

    Range("A1048576").End(xlUp).Offset(1, 0).Select

     Dim F As Integer

        F = 1
        Do While Range("A" & F).Value <> ""
            F = i + 1
        Loop

        Range("A" & F).Select

    ActiveSheet.Paste

    Else

    MsgBox ("Do not have Closed Cases")

    End If

    countline = countline + 1
    checkcell = Cells(countline, 1).Value
        Wend

    MsgBox ("Do not have Closed Cases")
    End Sub

    Wednesday, June 15, 2016 3:34 PM

All replies

  • Instead of looping through all of the data it is better to apply AutoFilter and then copy and paste the visible rows. In the code below I have provided 2 options for the rows to be copied and pasted.

    The first option INCLUDES the column headers plus the data to the output worksheet.

    The second option EXCLUDES the column headers and only copies the data. (This method is used if the column headers already exist on the destination sheet or to append data to the bottom of existing data on the destination sheet).

    Note: Code has been edited since initial posting. Count of cells to establish if data is present was incorrect.

    Sub ExportDatabase_1()
        'Code copies and pastes INCLUDING column headers
        Dim wsSource As Worksheet
        Dim wsDestin As Worksheet
        Dim rngToCopy As Range
        Dim rngDestin As Range
        Dim lngColFilter As Long
        Dim strFilter As String
       
      
        Set wsSource = Worksheets("Sheet1")  'Edit "Sheet1" to your source data sheet name
        Set wsDestin = Worksheets("Database")   'Edit "Database" to destination worksheet
        strFilter = "Closed"    'Edit "Closed" to required string to filter
       
        With wsSource
            lngColFilter = .Range("J:J").Column     'Edit "J:J" to column to be filtered
            .AutoFilterMode = False     'Turn off AutoFilter (if on) to reset
            .UsedRange.AutoFilter
            With .AutoFilter.Range
                .AutoFilter Field:=lngColFilter, Criteria1:=strFilter
                If .Columns(1).SpecialCells(xlCellTypeVisible).Cells.Count > 1 Then
                    'Following code INCLUDES column headers
                    Set rngToCopy = .SpecialCells(xlCellTypeVisible)
                Else
                    MsgBox ("Do not have Closed Cases")
                End If
            End With
        End With
       
        With wsDestin
            'Use following line when including column headers on destination sheet
            Set rngDestin = .Cells(.Rows.Count, "A").End(xlUp)
        End With
        rngToCopy.Copy Destination:=rngDestin
        wsSource.AutoFilterMode = False
    End Sub

    Sub ExportDatabase_2()
        'Code copies and pastes EXCLUDING column headers
        Dim wsSource As Worksheet
        Dim wsDestin As Worksheet
        Dim rngToCopy As Range
        Dim rngDestin As Range
        Dim lngColFilter As Long
        Dim strFilter As String
       
      
        Set wsSource = Worksheets("Sheet1")  'Edit "Sheet1" to your source data sheet name
        Set wsDestin = Worksheets("Database")   'Edit "Database" to destination worksheet
        strFilter = "Closed"    'Edit "Closed" to required string to filter
       
        With wsSource
            lngColFilter = .Range("J:J").Column     'Edit "J:J" to column to be filtered
            .AutoFilterMode = False     'Turn off AutoFilter (if on) to reset
            .UsedRange.AutoFilter
            With .AutoFilter.Range
                .AutoFilter Field:=lngColFilter, Criteria1:=strFilter
                'Following code EXCLUDES column headers
                If .Columns(1).SpecialCells(xlCellTypeVisible).Cells.Count > 1 Then
                    Set rngToCopy = .Offset(1, 0) _
                                    .Resize(.Rows.Count - 1, .Columns.Count) _
                                    .SpecialCells(xlCellTypeVisible)
                Else
                    MsgBox ("Do not have Closed Cases")
                End If
            End With
        End With
       
        With wsDestin
            'Use following line when not copying column headers
            'and to append to bottom of existing data on destination sheet
            Set rngDestin = .Cells(.Rows.Count, "A").End(xlUp).Offset(1, 0)
        End With
        rngToCopy.Copy Destination:=rngDestin
        wsSource.AutoFilterMode = False
    End Sub


    Regards, OssieMac


    • Edited by OssieMac Sunday, June 19, 2016 12:49 AM
    Friday, June 17, 2016 10:53 AM
  • Note that the code in my previous post has been edited. The If statement to count the cells to establish if data is visible was incorrect. It did not contain the SpecialCells part.

    Regards, OssieMac

    Sunday, June 19, 2016 12:51 AM