Macro to move data

[M.A.Tyler]

I need to move the data contained in Sheet1,W:BB, in rows that Sheet1, Column
D match Sheet"Answers" A3 and that Column BA (sheet1) contains 1.

Can someone help with a method for performing this miracle?

Thanks,

M.A.Tyler

 

[M.A.Tyler]

Failed to mention where I would like to put the information being moved. To
Sheet"answers" starting in cell B4.

Thanks again.

 

[Norman Jones]

Hi M,

I have assumed: that you want to copy data
for all rows in columns W:BB where:

- Column D value = "Answers"
and
- Column BA value = 1

I have further assumed that once copied,
the original data is to be deleted.

Assuming that this accords with your
requirements, in a standard module
(see below), paste the following code:

'==========>>
Option Explicit

Public Sub Tester()
Dim WB As Workbook
Dim SH As Worksheet
Dim Rng As Range
Dim copyRng As Range
Dim destRng As Range
Dim iRow As Long
Dim i As Long
Dim CalcMode As Long
Const sStr As String = "Answers"
Const dVal As Double = 1

Set WB = Workbooks("myBook.xls") '<<==== CHANGE
Set SH = WB.Sheets("Sheet1") '<<==== CHANGE

Set destRng = WB.Sheets("Answers").Range("B4")

With SH
iRow = LastRow(SH, .Columns("A:A"))
Set Rng = .Range("W1:BB" & iRow)
End With

On Error GoTo XIT
With Application
CalcMode = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With

With SH
For i = 1 To iRow
If LCase(.Cells(i, "D").Value) = LCase(sStr) _
And .Cells(i, "BA").Value = dVal Then
If copyRng Is Nothing Then
Set copyRng = .Range(.Cells(i, "W"), _
.Cells(i, "BB"))
Else
Set copyRng = _
Union(.Range(.Cells(i, "W"), _
.Cells(i, "BB")), copyRng)
End If
End If
Next i
End With

If Not copyRng Is Nothing Then
copyRng.Copy Destination:=destRng
copyRng.ClearContents
Else
'nothing found, do nothing
End If

XIT:

With Application
.Calculation = CalcMode
.ScreenUpdating = True
End With

End Sub

'--------------->
Function LastRow(SH As Worksheet, _
Optional Rng As Range)
If Rng Is Nothing Then
Set Rng = SH.Cells
End If

On Error Resume Next
LastRow = Rng.Find(What:="*", _
After:=Rng.Cells(1), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
On Error GoTo 0
End Function

'<<==========

Alt-F11 to open the VBA Editor
Menu | Insert | Module | Paste the above code
Alt-F11 to return to Excell
Alt-F8 to open the Macros window
Select "|Tester" | Run

 

[M.A.Tyler]

Hi Norman,

First let me thank you for your efforts, I certainly appreciate the help.

I think we're close to the solution, just a couple tweeks. First there are
two worksheets Sheet1 and "Answers". It's the first "assumtion" that is the
problem. Column D value (in sheet1) must = value in sheet "Answers" cell A3
in addition too (second part) Sheet1 Column BA value = 1. Then you are
correct, copy data for all rows in columns W:BB, where both criteria are met.

Also I would prefer, that once copied, the original data be kept, as it is
used from that location in subsequent calculations.

I apologise for keeping you guessing, again thanks for the help!

Regards,

Mike.

 

[Norman Jones]

Hi Mike,

Try:

'==========>>
Option Explicit

Public Sub Tester()
Dim WB As Workbook
Dim SH As Worksheet
Dim SH2 As Worksheet
Dim Rng As Range
Dim copyRng As Range
Dim destRng As Range
Dim iRow As Long
Dim i As Long
Dim CalcMode As Long
Dim sStr As String
Const dVal As Double = 1

Set WB = Workbooks("myBook.xls") '<<==== CHANGE

With WB
Set SH = .Sheets("Sheet1")
Set SH2 = .Sheets("Answers")
End With

With SH2
sStr = .Range("A3")
Set destRng = .Range("B4")
End With

With SH
iRow = LastRow(SH, .Columns("A:A"))
Set Rng = .Range("W1:BB" & iRow)
End With

On Error GoTo XIT
With Application
CalcMode = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With

With SH
For i = 1 To iRow
If LCase(.Cells(i, "D").Value) = LCase(sStr) _
And .Cells(i, "BA").Value = dVal Then
If copyRng Is Nothing Then
Set copyRng = .Range(.Cells(i, "W"), _
.Cells(i, "BB"))
Else
Set copyRng = _
Union(.Range(.Cells(i, "W"), _
.Cells(i, "BB")), copyRng)
End If
End If
Next i
End With

If Not copyRng Is Nothing Then
copyRng.Copy Destination:=destRng
Else
'nothing found, do nothing
End If

XIT:

With Application
.Calculation = CalcMode
.ScreenUpdating = True
End With

End Sub

'--------------->
Function LastRow(SH As Worksheet, _
Optional Rng As Range)
If Rng Is Nothing Then
Set Rng = SH.Cells
End If

On Error Resume Next
LastRow = Rng.Find(What:="*", _
After:=Rng.Cells(1), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
On Error GoTo 0
End Function
'<<==========

 

[M.A.Tyler]

Perfect, Made the one change and whala!
Can't Thank you enough Norman

 

[M.A.Tyler]

Hi Norman,
While this works very well, I'm wondering if there is a way to expand it? So
sStr would =Sheets("Answers") B3 (I moved that from A3) to also include "B"
14, 25, 36, 47, 58, 69, 80, 91, 102, 113 and 124. Likewise the destRng has
been moved to column "J" to include row numbers 4, 15, 26, 37, 48, 59, 70,
81, 92, 103, 114 and 125. The criteria has remained the same needing a match
in Sheet1 column "D" and column BA=1.

Sorry for the headache, but I attempted to make these adjustments myself to
no avail. Not quite savy enough to understand all of the code. Before I end
up with several unnecessary modules for each macro, I thought it might be
best to attempt expanding this one.

I certainly apprieciate al of your help!

Mike.