PDA

View Full Version : A few small problems...



stenlake1
06-21-2007, 01:49 AM
Hi all,

With a lot of help from xld, I have the following part of my script:


With ActiveSheet
kLastRow = .Cells(.Rows.Count, TEST_COLUMN).End(xlUp).Row
For k = 2 To kLastRow
If Application.CountIf(.Range(.Range("A1"), .Cells(k, "A")), .Cells(k, "A")) = 1 Then
If MsgBox("Row " & k & ", Line " & .Cells(k, "A").Value & vbNewLine & _
"Interpolate this value?", vbYesNo) = vbYes Then
Set sh = Worksheets.Add(After:=Worksheets(Worksheets.Count))
sh.Name = .Cells(k, "A").Value
.Range(.Cells(k, "A"), .Cells(k, "A").End(xlDown)).Resize(, 2).Copy sh.Range("A1")
.Range(.Cells(k, "A"), .Cells(k, "A").End(xlDown)).Offset(0, 4).Resize(, 2).Copy sh.Range("E1")
.Activate
sh.Activate

I want to do a couple of things:

1. When there is only one value of k, I want the user to be prompted with a message "This value only has one point and cannot be interpolated", which then loops back and finds the next value of k.

2. When it asks "Interpolate this value?", I would like the current position on the worksheet where k is to be shown on the screen?

If you can help me with either, I would greatly appreaciate it.

Best regards.

Bob Phillips
06-21-2007, 02:03 AM
Public Sub ProcessData()
Const TEST_COLUMN As String = "A" '<=== change to suit
Dim k As Long
Dim kLastRow As Long
Dim sh As Worksheet

With ActiveSheet
kLastRow = .Cells(.Rows.Count, TEST_COLUMN).End(xlUp).Row
For k = 2 To kLastRow
If Application.CountIf(.Range(.Range("A1"), .Cells(k, "A")), .Cells(k, "A")) = 1 Then
.Activate
.Cells(k, "A").Select
If Application.CountIf(.Range("A1").Resize(kLastRow), .Cells(k, "A")) = 1 Then
MsgBox "Row " & k & ", Line " & .Cells(k, "A").Value & vbNewLine & _
"This value only has one point and cannot be interpolated"
ElseIf MsgBox("Row " & k & ", Line " & .Cells(k, "A").Value & vbNewLine & _
"Interpolate value?", vbYesNo) = vbYes Then

Set sh = Worksheets.Add(After:=Worksheets(Worksheets.Count))
sh.Name = .Cells(k, "A").Value
.Range(.Cells(k, "A"), .Cells(k, "A").End(xlDown)).Resize(, 2).Copy sh.Range("A1")
.Range(.Cells(k, "A"), .Cells(k, "A").End(xlDown)).Offset(0, 4).Resize(, 2).Copy sh.Range("E1")
sh.Activate
End If
End If
Next k
End With

End Sub