M
M.A.Tyler
I'm using the Macro below, I have no idea how it works, but it dose what I
need it to do. However I use it in the same workbook everyday, and then save
it (save as) as that particular date. The trouble is once saved this macro
won't work, perhaps I didn't put it into the right module, or perhaps thats
the way it was designed to work, to only one name. Either way I'm
appreciative that someone (I've tried to contact them directly, but no luck)
took the time to help me, and write it. And would like to know if there is a
way to fix it? Also it appears that all of my saved workbooks are now
attempting to share this macro, is that normal?
Here is the code:
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("Test.00.xls") '<<==== CHANGE
With WB
Set SH = .Sheets("Sheet1")
Set SH2 = .Sheets("Answers")
End With
With SH2
sStr = .Range("B3")
Set destRng = .Range("L4")
End With
With SH
iRow = LastRow(SH, .Columns("A:A"))
Set Rng = .Range("G1: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, "G"), _
..Cells(i, "BB"))
Else
Set copyRng = _
Union(.Range(.Cells(i, "G"), _
..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
Appreciate any ideas!
need it to do. However I use it in the same workbook everyday, and then save
it (save as) as that particular date. The trouble is once saved this macro
won't work, perhaps I didn't put it into the right module, or perhaps thats
the way it was designed to work, to only one name. Either way I'm
appreciative that someone (I've tried to contact them directly, but no luck)
took the time to help me, and write it. And would like to know if there is a
way to fix it? Also it appears that all of my saved workbooks are now
attempting to share this macro, is that normal?
Here is the code:
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("Test.00.xls") '<<==== CHANGE
With WB
Set SH = .Sheets("Sheet1")
Set SH2 = .Sheets("Answers")
End With
With SH2
sStr = .Range("B3")
Set destRng = .Range("L4")
End With
With SH
iRow = LastRow(SH, .Columns("A:A"))
Set Rng = .Range("G1: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, "G"), _
..Cells(i, "BB"))
Else
Set copyRng = _
Union(.Range(.Cells(i, "G"), _
..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
Appreciate any ideas!