Macro: copy and paste without blanks

[KSAExcel]

Hi all,

I don't have much knowledge of VBA but am using research and help I can get from the web to create a tool. I am stuck at a stage and was wondering if anyone could help me.

I have the following in sheet 1:

[TABLE="width: 1552"]
<tbody>[TR]
[TD="width: 194"]SKU NUMBER[/TD]
[TD="width: 194"]Supplier[/TD]
[TD="width: 194"]ISSUE[/TD]
[TD="width: 194"]RECEIPT DATE[/TD]
[TD="width: 194"]QUANTITY[/TD]
[TD="width: 194"]PURGE NUMBER[/TD]
[TD="width: 194"]ORDER NUMBER[/TD]
[TD="width: 194"]CFC ACTION (RECEIPT OR RETURN)[/TD]
[/TR]
</tbody>[/TABLE]



What this sheet does is when type in the supplier name, most of the other data gets populated. However, once that is done, I want to be able to archive this data into sheet2 every single time I use it using a macro in such a way that it only copies non blank cells and paste it after populated cells in sheet2. I have tried a code which I found on the web that does paste from sheet1 to sheet2 but leaves a huge gap between the old and freshly pasted data.

I would be very grateful if anyone can help me.

Thanks a lot


KSAExcel

 

[kevatarvind]

so you want to look in Column Supplier name if cell is non blank then that entire row you want to copy and paste to sheet 2 last blank row ?

if i am right then in Which is the column of Supplier name ?

 

[KSAExcel]

Hi kevatarvind,

Thanks for the reply. And yeap, look in coulmn supplier name and if not blank then copy not all rows but the 8 of them displayed (A3:I3), copy and paste it in sheet 2, in the next blank cell. I would have data from previous days there, so excel should look at that and go to the next empty row and paste it in. Supplier name will be in from B3 onward.

Thank you

 

[kevatarvind]

try below code

Sub Test()
Application.ScreenUpdating = False
Sheets("Sheet1").Select ' Change Sheet Name As Per Your Sheet Name Where Data Is Stored
lr = Range("B" & Rows.Count).End(xlUp).Row
Range("B3").Select
For i = 3 To lr
If Cells(i, 2) <> "" Then Range(Cells(i, 1), Cells(i, 9)).Copy Sheets("Sheet2").Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
Next
Application.ScreenUpdating = True
End Sub

 

[KSAExcel]

try below code

Sub Test()
Application.ScreenUpdating = False
Sheets("Sheet1").Select ' Change Sheet Name As Per Your Sheet Name Where Data Is Stored
lr = Range("B" & Rows.Count).End(xlUp).Row
Range("B3").Select
For i = 3 To lr
If Cells(i, 2) <> "" Then Range(Cells(i, 1), Cells(i, 9)).Copy Sheets("Sheet2").Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
Next
Application.ScreenUpdating = True
End Sub

Thanks a lot kevatarvind! It works like a charm!


Regards


KSAExcel

 

[kevatarvind]

KSAExcel,

Thanks For The Feedback

Glad to Help

Come back any time

 

[KSAExcel]

KSAExcel,

Thanks For The Feedback

Glad to Help

Come back any time

I have 1 more query. I am using the following code that I have acquired from the web to send email from outlook using excel for the same sheet as above. At this point it selects a range and then send that to the recipients. However, as we have done here, I would like to only copy nonblank cells even when the list gets bigger. Could you please highlight what needs changing in the following code:

Sub Mail_Selection_Range_Outlook_Body()


'Working in Excel 2000-2013
Dim rng As Range
Dim OutApp As Object
Dim OutMail As Object


Set rng = Nothing
On Error Resume Next
'Only the visible cells in the selection
Set rng = Selection.SpecialCells(xlCellTypeVisible)
'You can also use a fixed range if you want
Set rng = Sheets("email").Range("A1:I50").SpecialCells(xlCellTypeVisible)
On Error GoTo 0


If rng Is Nothing Then
MsgBox "The selection is not a range or the sheet is protected" & _
vbNewLine & "please correct and try again.", vbOKOnly
Exit Sub
End If


With Application
.EnableEvents = False
.ScreenUpdating = False
End With


Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)


On Error Resume Next
With OutMail
.To = "example@gmail.com"
.CC = ""
.BCC = ""
.Subject = "example"
.HTMLBody = RangetoHTML(rng)
.Display 'or use .Display
End With
On Error GoTo 0


With Application
.EnableEvents = True
.ScreenUpdating = True
End With


Set OutMail = Nothing
Set OutApp = Nothing
End Sub




Function RangetoHTML(rng As Range)
' Changed by Ron de Bruin 28-Oct-2006
' Working in Office 2000-2013
Dim fso As Object
Dim ts As Object
Dim TempFile As String
Dim TempWB As Workbook


TempFile = Environ$("temp") & "\" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"


'Copy the range and create a new workbook to past the data in
rng.Copy
Set TempWB = Workbooks.Add(1)
With TempWB.Sheets(1)
.Cells(1).PasteSpecial Paste:=8
.Cells(1).PasteSpecial xlPasteValues, , False, False
.Cells(1).PasteSpecial xlPasteFormats, , False, False
.Cells(1).Select
Application.CutCopyMode = False
On Error Resume Next
.DrawingObjects.Visible = True
.DrawingObjects.Delete
On Error GoTo 0
End With


'Publish the sheet to a htm file
With TempWB.PublishObjects.Add( _
SourceType:=xlSourceRange, _
Filename:=TempFile, _
Sheet:=TempWB.Sheets(1).Name, _
Source:=TempWB.Sheets(1).UsedRange.Address, _
HtmlType:=xlHtmlStatic)
.Publish (True)
End With


'Read all data from the htm file into RangetoHTML
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
RangetoHTML = ts.readall
ts.Close
RangetoHTML = Replace(RangetoHTML, "align=center xublishsource=", _
"align=left xublishsource=")


'Close TempWB
TempWB.Close savechanges:=False


'Delete the htm file we used in this function
Kill TempFile


Set ts = Nothing
Set fso = Nothing
Set TempWB = Nothing
End Function




Thanks very much!