Merging Two Codes Into one code

L

LoveCandle

Hi everybody,

I have these two codes:

The first one works on selecting specific records whose values are mor
than zero, and the other one is working on copying the selected record
by the first code to another sheet.

I tried to merge them in one code to get the same purpose but I foun
the second code move all records even those who have 0 value records
so I would like you please to help me in this matter.

First Code:

Code
-------------------
Sub Highlight ()
Dim iRow As Long
Dim FirstRow As Long
Dim LastRow As Long

With ActiveSheet
FirstRow = 7
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row

For iRow = FirstRow To LastRow
If .Cells(iRow, "A").Value > 0 Then
If myRng Is Nothing Then
Set myRng = .Cells(iRow, "A")
Else
Set myRng = Union(.Cells(iRow, "A"), myRng)
End If
End If
Next iRow

If myRng Is Nothing Then
MsgBox "No records to select"
Else
Intersect(myRng.EntireRow, .Range("a:j")).Select
End If
End With

End Su
-------------------

Second Code:

Code
-------------------
Sub Copy_Move()
Dim srcRng As Range
Dim destRng As Range
Dim Lrow As Long
Lrow = Cells(Rows.Count, "A").End(xlUp).Row
Set srcRng = ActiveSheet.Range("A7:J" & Lrow)
Set destRng = Sheets("100"). _
Cells(Rows.Count, "A").End(xlUp)(2)
srcRng.Copy Destination:=destRng
MsgBox "Data moved to the other sheet successfully", vbInformation, "Done"
End Su
 
D

Dave Peterson

Maybe...

Option Explicit
Sub Highlight()
Dim iRow As Long
Dim FirstRow As Long
Dim LastRow As Long
Dim myRng As Range

Dim srcRng As Range
Dim destRng As Range

With ActiveSheet
FirstRow = 7
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row

For iRow = FirstRow To LastRow
If .Cells(iRow, "A").Value > 0 Then
If myRng Is Nothing Then
Set myRng = .Cells(iRow, "A")
Else
Set myRng = Union(.Cells(iRow, "A"), myRng)
End If
End If
Next iRow

If myRng Is Nothing Then
MsgBox "No records to select"
Else
Set srcRng = Intersect(myRng.EntireRow, .Range("a:j"))
With Worksheets("100")
Set destRng = .Cells(.Rows.Count, "A").End(xlUp).Offset(1, 0)
End With

srcRng.Copy _
Destination:=destRng

MsgBox "Data moved to the other sheet successfully", _
vbInformation, "Done"
End If
End With
End Sub

(Untested, but it compiled ok)
 
L

LoveCandle

Thank you sooooooooo much >> that is really fantastic and what I need
exactly,

I have also another two codes need to be merged, I almost succeeded
merging them but the problem is that the second code which should be
working on the sheets2, it works on the active sheet instead >> I don't
know why!!!

First Code:

Code:
--------------------
Public Sub Tarheel()
If [B6].Value = "" Then
MsgBox "No records to be moved to the other sheet", vbExclamation, "Sorry"
Else
Dim srcRng As Range
Dim destRng As Range
Dim Lrow As Long
Lrow = Cells(Rows.Count, "B").End(xlUp).Row
Set srcRng = ActiveSheet.Range("B6:W" & Lrow)
Set destRng = Sheets("sheet2"). _
Cells(Rows.Count, "B").End(xlUp)(2)
srcRng.Copy Destination:=destRng
srcRng.ClearContents
MsgBox "Records were successfully moved", vbInformation, "Done"
End If
End Sub
--------------------

Second Code:

Code:
--------------------
Sub Numbering()
With sheets2
For i = 2 To Cells(Rows.Count, "B").End(xlUp).Row
If Cells(i, "B").Value <> "" Then
Cells(i, "A").Value = i - 1
End If
Next i
End With
End Sub
--------------------

Codes after merging,

Code:
--------------------
Public Sub Tarheel()
If [B6].Value = "" Then
MsgBox "No records to be moved to the other sheet", vbExclamation, "Sorry"
Else
Dim srcRng As Range
Dim destRng As Range
Dim Lrow As Long
Lrow = Cells(Rows.Count, "B").End(xlUp).Row
Set srcRng = ActiveSheet.Range("B6:W" & Lrow)
Set destRng = Sheets("sheet2"). _
Cells(Rows.Count, "B").End(xlUp)(2)
srcRng.Copy Destination:=destRng
srcRng.ClearContents
With sheets2
For i = 2 To Cells(Rows.Count, "B").End(xlUp).Row
If Cells(i, "B").Value <> "" Then
Cells(i, "A").Value = i - 1
End If
Next i
End With
"Records were successfully moved", vbInformation, "Done"
End If
End Sub
 
D

Dave Peterson

Maybe....

Option Explicit
Public Sub Tarheel()
Dim srcRng As Range
Dim destRng As Range
Dim Lrow As Long
If ActiveSheet.Range("b6").Value = "" Then
MsgBox "No records to be moved to the other sheet", _
vbExclamation, "Sorry"
Else
Lrow = Cells(Rows.Count, "B").End(xlUp).Row
Set srcRng = ActiveSheet.Range("B6:W" & Lrow)
Set destRng = Sheets("sheet2"). _
Cells(Rows.Count, "B").End(xlUp)(2)
srcRng.Copy Destination:=destRng
srcRng.ClearContents
With Worksheets("sheet2")
For i = 2 To .Cells(.Rows.Count, "B").End(xlUp).Row
If .Cells(i, "B").Value <> "" Then
.Cells(i, "A").Value = i - 1
End If
Next i
End With
MsgBox "Records were successfully moved", vbInformation, "Done"
End If
End Sub

I changed this line:
with sheets2
to
With Worksheets("sheet2")
(change it to what you need)

And when you use "with/end with", you'll need leading dots on the things that
belong to that "with" object.

.cells(i,"B").value....
with the dot in front of cells, excel knows that it belongs to the object in the
previous With statement.

Without the dot, excel knows that you mean the activesheet (well, in a general
module).



Thank you sooooooooo much >> that is really fantastic and what I need
exactly,

I have also another two codes need to be merged, I almost succeeded
merging them but the problem is that the second code which should be
working on the sheets2, it works on the active sheet instead >> I don't
know why!!!

First Code:

Code:
--------------------
Public Sub Tarheel()
If [B6].Value = "" Then
MsgBox "No records to be moved to the other sheet", vbExclamation, "Sorry"
Else
Dim srcRng As Range
Dim destRng As Range
Dim Lrow As Long
Lrow = Cells(Rows.Count, "B").End(xlUp).Row
Set srcRng = ActiveSheet.Range("B6:W" & Lrow)
Set destRng = Sheets("sheet2"). _
Cells(Rows.Count, "B").End(xlUp)(2)
srcRng.Copy Destination:=destRng
srcRng.ClearContents
MsgBox "Records were successfully moved", vbInformation, "Done"
End If
End Sub
--------------------

Second Code:

Code:
--------------------
Sub Numbering()
With sheets2
For i = 2 To Cells(Rows.Count, "B").End(xlUp).Row
If Cells(i, "B").Value <> "" Then
Cells(i, "A").Value = i - 1
End If
Next i
End With
End Sub
--------------------

Codes after merging,

Code:
--------------------
Public Sub Tarheel()
If [B6].Value = "" Then
MsgBox "No records to be moved to the other sheet", vbExclamation, "Sorry"
Else
Dim srcRng As Range
Dim destRng As Range
Dim Lrow As Long
Lrow = Cells(Rows.Count, "B").End(xlUp).Row
Set srcRng = ActiveSheet.Range("B6:W" & Lrow)
Set destRng = Sheets("sheet2"). _
Cells(Rows.Count, "B").End(xlUp)(2)
srcRng.Copy Destination:=destRng
srcRng.ClearContents
With sheets2
For i = 2 To Cells(Rows.Count, "B").End(xlUp).Row
If Cells(i, "B").Value <> "" Then
Cells(i, "A").Value = i - 1
End If
Next i
End With
"Records were successfully moved", vbInformation, "Done"
End If
End Sub
Click to expand...
 
L

LoveCandle

Thank you for helping me in this case Mr. Dave

When I run the code it stop at letter i of this line


Code:
--------------------
For i = 2 To .Cells(.Rows.Count, "B").End(xlUp).Row
--------------------


and when I run the numbering code only it works perperly, I don't know
why, you may try and find out the problem.

Thanks,
 
D

Dave Peterson

I think you may have changed something from the suggested code.

You'll have to post the code you're using.
 
L

LoveCandle

I copied the code again and pasted it in the module and the same problem
appeared >> I don't kow why!!!

Can U please help me, and attach me a file if u can>

Thank you,
 
L

LoveCandle

I am using the same code mentioned above,


Code:
--------------------
Option Explicit
Public Sub Tarheel()
Dim srcRng As Range
Dim destRng As Range
Dim Lrow As Long
If ActiveSheet.Range("b6").Value = "" Then
MsgBox "No records to be moved to the other sheet", _
vbExclamation, "Sorry"
Else
Lrow = Cells(Rows.Count, "B").End(xlUp).Row
Set srcRng = ActiveSheet.Range("B6:W" & Lrow)
Set destRng = Sheets("sheet2"). _
Cells(Rows.Count, "B").End(xlUp)(2)
srcRng.Copy Destination:=destRng
srcRng.ClearContents
With Worksheets("sheet2")
For i = 2 To .Cells(.Rows.Count, "B").End(xlUp).Row
If .Cells(i, "B").Value <> "" Then
.Cells(i, "A").Value = i - 1
End If
Next i
End With
MsgBox "Records were successfully moved", vbInformation, "Done"
End If
End Sub
 
D

Dave Peterson

In your code, there are references to Sheet2 and activesheet.

Option Explicit
Public Sub Tarheel()
Dim srcRng As Range
Dim destRng As Range
Dim i As Long
Dim Lrow As Long
If ActiveSheet.Range("b6").Value = "" Then
MsgBox "No records to be moved to the other sheet", _
vbExclamation, "Sorry"
Else
Lrow = ActiveSheet.Cells(Rows.Count, "B").End(xlUp).Row
Set srcRng = ActiveSheet.Range("B6:W" & Lrow)
Set destRng = Sheets("sheet2").Cells(Rows.Count, "B").End(xlUp)(2)
srcRng.Copy Destination:=destRng
srcRng.ClearContents
With Worksheets("sheet2")
For i = 2 To .Cells(.Rows.Count, "B").End(xlUp).Row
If .Cells(i, "B").Value <> "" Then
.Cells(i, "A").Value = i - 1
End If
Next i
End With
MsgBox "Records were successfully moved", vbInformation, "Done"
End If
End Sub

Are they pointing to the correct sheets for you?

Your code worked ok for me--although, that doesn't mean it does what you want.
 
L

LoveCandle

Thank you sooooooooooo much ,, that is exaclty what I want ..

Thank you for the effort you exerted for me,
 

Ask a Question

Want to reply to this thread or ask your own question?

You'll need to choose a username for the site, which only take a couple of moments. After that, you can post your question and our members will help you out.

Ask a Question

Similar Threads

Insert Row based on count and copy range to inserted rows 2
Insert rows by group and copy value 2
Date format converted from UK to US format 2
merge cells part deux 2
Macro Functionality 4
function question?? 12
Page break issues 1
Coding Help 5

Top