Hi Cuneyt,

I did not receive your email. Please re-send it.

In response to your previous post, it looks like what you really want is to
copy non-empty rows EVEN IF THEY ARE PARTIALLY FILLED. If so, we need to
change a few lines in the code as, it currently only copies "filled rows",
which is what you asked for. We can hange it so it will copy partially filled
rows and/or completely filled rows.

Here's the code you need to do this:

Sub CopyNonEmptyRows()
' Copies the contents of each non-empty row in a range,
' to the next empty row in wbkTarget (another workbook).
' If wbkTarget isn't open, it opens it.
' wbkTarget is saved and closed.
' Requires bBookIsOpen() and bFileExists() functions.

 Dim RangeToExport As Range
 Dim wbkTarget As Workbook
 Dim lNextRow As Long, r As Long
 Dim iCols As Integer
 
 Const sPath As String = "C:\"
 Const sFilename As String = "FedTest.xls"
 Const sSht As String = "Data"
 
 'Get a reference to the data to export
 Set RangeToExport = ActiveSheet.Range("$A$1:$C$6")
 iCols = RangeToExport.Columns.Count
 
 'Get a reference to wbkTarget
 If Not bBookIsOpen(sFilename) Then
   If bFileExists(sPath & sFilename) Then
     Set wbkTarget = Workbooks.Open(sPath & sFilename)
   Else
     MsgBox "The target file does not exist !", vbExclamation + vbOKOnly
     Exit Sub
   End If
 Else
   Set wbkTarget = Workbooks(sFilename)
 End If
 
 On Error GoTo ErrorExit
 
 'Get the next empty row
 With wbkTarget.Sheets(sSht)
   If IsEmpty(.Cells(1)) Then
     lNextRow = 1
   Else
     lNextRow = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
   End If
 End With
 
 'Export the data
 Application.ScreenUpdating = False
 With RangeToExport
   For r = 1 To RangeToExport.Rows.Count
     'To copy non-empty rows (includes rows with some blank cells)
     If Application.WorksheetFunction.CountIf(.Rows(r), "") < iCols Then
       .Rows(r).Copy
       With wbkTarget.Sheets(sSht).Range("$A$" & lNextRow)
         .PasteSpecial Paste:=xlPasteFormats, _
           Operation:=xlNone, _
           SkipBlanks:=False, _
           Transpose:=False
         .PasteSpecial Paste:=xlPasteValues, _
           Operation:=xlNone, _
           SkipBlanks:=False, _
           Transpose:=False
         Application.CutCopyMode = False
       End With
       lNextRow = lNextRow + 1
     End If
   Next
 End With
 
 'Save any changes here
 wbkTarget.Save

ErrorExit:
 'If no error, changes were already saved.
 'If error, don't save.
 wbkTarget.Close savechanges:=False
   
End Sub

Regards,
Garry