Never pastes in right line. Nearest number to number in a given cell.

Because the data in my spreadsheet is copied/typed in from a printed sheet thats in a set order.

Column A on the printed sheet is formatted by text (i know - why) so every thing starting with 1 is bunched together.

PHP Code: 

Option Explicit
Sub WakesMB()
 Dim WF As Object, Rng As Range, sRng As Range
 Dim Rws As Long, Min_ As Long, jJ As Long, Tmp As Long
 
 Rws = Cells(Rows.Count, "a").End(xlUp).Row
 Set Rng = Range("A3:A" & Rws)
 Set WF = Application.WorksheetFunction
 Min_ = WF.Min(Range(Cells(3, "A"), Cells(Rws, "A")))
 For jJ = Cells(1, 4).Value - 1 To Min_ Step -1
    Set sRng = Rng.Find(jJ, , xlFormulas, xlWhole)
    If sRng Is Nothing Then
        Tmp = jJ
    Else
        sRng.Offset(1).EntireRow.Insert
        sRng.Offset(1).Resize(, 4).Value = Cells(2, "A").Resize(, 4).Value
        Cells(2, "A").Resize(, 4).Value = ""
        Exit For
    End If
 Next jJ
End Sub 


Pic121127.JPG

rylo,

Thanks for that, just one problem if my new account number is the new highest number it does not work....?

Sub aaa()
For i = Cells(Rows.Count, 1).End(xlUp).Row To 3 Step -1
    If Cells(i, 1) > Cells(1, 1) And Cells(i - 1, 1) < Cells(1, 1) Then
      Cells(i, 1).EntireRow.Insert shift:=xlDown
      Range("1:1").Copy Destination:=Cells(i, 1)
      Range("A1:B1").ClearContents
    End If
  Next i

End Sub

And the next question is how do I make this search also happen on Sheet 2 and Sheet 3.???????

Been at this to long tonight i just cant get in straight in my head......


Regards Wales MB

Hi

Expanded for a new max item, or new min item.

Sub aaa()
  For i = Cells(Rows.Count, 1).End(xlUp).Row To 3 Step -1
    If Cells(2, 1) > Cells(i, 1) Then 'new max item
      Range("A2:B2").Copy Destination:=Cells(i + 1, 1)
      Range("A2:B2").ClearContents
    ElseIf Cells(2, 1) < Cells(3, 1) And Len(Cells(2, 1)) > 0 Then 'new min item
      Cells(3, 1).EntireRow.Insert shift:=xlDown
      Range("A2:B2").Copy Destination:=Cells(3, 1)
      Range("A2:B2").ClearContents
    End If
    
    If Cells(i, 1) > Cells(2, 1) And Cells(i - 1, 1) < Cells(2, 1) Then
      Cells(i, 1).EntireRow.Insert shift:=xlDown
      Range("A2:B2").Copy Destination:=Cells(i, 1)
      Range("A2:B2").ClearContents
    End If
  Next i
End Sub

You should be able to run this on subsequent sheets, assuming that they all follow the same construct. Or do you mean that you want to take an item from sheet 1, and put it to all sheets?

rylo

Sorry just realised I amended the post instead of inserting a new one.

Bump please

Hi

Your example file and your recut of my code don't seem to align. Can you recheck your example file and check and confirm exactly where the customer name and ID are going to be located.

Also, the data in column B is either not sorted, or text sorted. Exactly what is going to be the situation regarding this data, and any new data to be included (with regard to value cf text).

rylo

Hi Rylo

The attachment is a snap shot of the file i am working on.

Row 5 is the new customer line, A5 and B5 are customer name and account number.
B6 down is the current customers account number and A6 down would be there names,
there are over 500 on the original file, but they have to stay in the order they are in.

The daily data is supplied in hard copy only, never electronic so i cant change the
sort..... I suppose that column B is sorted as text hence the strange order, but this
can not be changed.... life is never straight forward.

When new customers decide to use this system we have to add them to this list normally
it is a new highest number, but occasionally one of the older numbers come on line.
and just to be difficult some of the really old ones have alpa codes (not numeric).

I tried to get the code you supplied to work hence it not linking up as you put it, I am very
new to all this so I have got confused, trying to make it work..... Sorry.

Hopefully that helps you understand.

Regards Mike

Hi

Open your example file from #7, delete row 42 (to get rid of the blank row item in column B), then try

Sub aaa()
  For i = Cells(Rows.Count, 2).End(xlUp).Row To 6 Step -1
    If Cells(5, 2) > Cells(i, 2) Then 'new max item
      Range("5:5").Copy Destination:=Cells(i + 1, 1)
      Range("A5:B5").ClearContents
    ElseIf Cells(5, 2) < Cells(6, 2) And Len(Cells(5, 2)) > 0 Then 'new min item
      Cells(6, 2).EntireRow.Insert shift:=xlDown
      Range("A2:B2").Copy Destination:=Cells(6, 1)
      Range("A5:B5").ClearContents
    End If
    
    If Cells(i, 2) > Cells(5, 2) And Cells(i - 1, 2) < Cells(5, 2) Then
      Cells(i, 2).EntireRow.Insert shift:=xlDown
      Range("5:5").Copy Destination:=Cells(i, 1)
      Range("A5:B5").ClearContents
    End If
  Next i
  
  Range("A5:B5").Value = Array("New Customer", "0")
End Sub

rylo

Thanks for that, I can see that I mixed up in a number of places.

I have loaded the code you supplied, and have attached file for you to see the following.

1. When putting in account 1 the code insert a line but leaves it blank? Account 1 is
using so I would not need to add them but i can not see why?

2. When putting in a new highest number 10074, it placed it on row 39 and not on
row 18, 10073 is on line 17, 9988 is on line 38.

Thanks again for your support.....

Thanks for you help.....

The finished code.....

Sub NewCustomer()
Dim num As Single, Rng As Range, Dn As Range, Mx As Single, oAd As String
Dim dMin As Double
 
For LC = Cells(Rows.Count, 2).End(xlUp).Row To 6
Next
FindString = Cells(5, 2)
 
If Trim(FindString) <> "" Then
    With Sheets("Data").Range("B6:B" & LC)
        Set Rng = .Find(What:=FindString, _
            After:=.Cells(.Cells.Count), _
            LookIn:=xlValues, _
            LookAt:=xlWhole, _
            SearchOrder:=xlByRows, _
            SearchDirection:=xlNext, _
            MatchCase:=False)
    If Not Rng Is Nothing Then
            MsgBox "This account number already exists"
            Cells(5, 2).Select
           
    Exit Sub
    End If
        End With
    End If
 
Set Rng = Range("B6:B" & LC - 28)
           
dMin = WorksheetFunction.Min(Rng)
           
    If Cells(5, 2) < Cells(dMin, 1) Then
            Range("5:5").Copy Destination:=Cells(6, 1)
            Cells(6, 1).EntireRow.Font.ColorIndex = xlAutomatic
            Range("A5:B5").Value = Array("New Customer", "0")
 
            MsgBox "The new account number has been added"
    Exit Sub
    End If
 
On Error Resume Next
            num = Cells(5, 2)
 
 
            Mx = Application.Max(Rng)
 
For Each Dn In Rng
    If Abs(num - Dn) < Mx Then
            Mx = Abs(num - Dn)
            oAd = Dn.Row
        End If
    Next Dn
 
Cells(oAd + 1, 1).EntireRow.Insert shift:=xlDown
            Range("5:5").Copy Destination:=Cells(oAd + 1, 1)
            Cells(oAd + 1, 1).EntireRow.Font.ColorIndex = xlAutomatic
            Range("A5:B5").Value = Array("New Customer", "0")
 
    MsgBox "The new account number has been added."
End Sub