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