VBA for Edit record

[santosh226001]

Hello all.

I m new to this forum.. we are lucking a help for my project for edit module..

We attach a workbook with sample data..

in this workbook 3 sheet.. (edit, prarup-1 & Praraup-2)



in Edit sheet a VBA code Exit following

This code work following in Cell F2 we choose exiting Road which one we want to edit..

After Dispaly Details of That road we can edit..

in Editing time it's possible we remove some row data.. or we add some new row data or no add or no remove.. only edit exiting row data..

After Edit we save edit data after press Y in cell J108

(with this code we edit data & same place where record exit previously)

Option Explicit
Dim Frng As Range, surng As Range


Private Sub Worksheet_Change(ByVal Target As Range)
On Error Resume Next
   If Target.Count > 1 Then Exit Sub
   If Target.Address(0, 0) = "F2" Then
      Dim r As Range, i&
      Dim S As Range, j&
      Dim Cr, Name As String
      
      Dim Firstname, LastName As String  ' Define Variable for Spilt Road Category (B2) & Nos (D2) data saparate
      Dim TL, STC, ETC As String         'Define Variable for Total Length(F2), Start Chainage(H2), End Chainage(J2)
[B]        Sheets("Edit").Protect Password:="san"[/B]


'Define 1st sheet where find target road i.e prarup-2
      Set r = Sheets("Prarup-1").Columns(2).Find(Target, LookAt:=xlWhole)
            Sheets("Edit").Unprotect Password:="san"
            Range("A6:j105").SpecialCells(2).ClearContents
      If r Is Nothing Then MsgBox "not found " & Target.Value, 64: Exit Sub
        For i = 1 To 100
          If Len(r(i + 1, 1)) = 0 Then Set r = Union(r, r(i + 1, 1)) Else Exit For
        Next i
      
'Define 2nd sheet where find target road i.e prarup-2
      Set S = Sheets("Prarup-2").Columns(3).Find(Target, LookAt:=xlWhole)
      For j = 1 To 100
          If Len(S(j + 1, 1)) = 0 Then Set S = Union(S, S(j + 1, 1)) Else Exit For
      Next j
      
      Application.EnableEvents = False


'Call data from Praraup-1 Sheet For Edit Road
      Me.Range("a6:a6").Resize(r.Rows.Count).Value = r.Offset(, 2).Resize(, 1).Value 'Kms
      Me.Range("B6:B6").Resize(r.Rows.Count).Value = r.Offset(, 4).Resize(, 1).Value 'Width
      Me.Range("E6:E6").Resize(r.Rows.Count).Value = r.Offset(, 5).Resize(, 1).Value 'Surface
      Me.Range("F6:G6").Resize(r.Rows.Count).Value = r.Offset(, 6).Resize(, 2).Value 'Renewal Month & Year
      Me.Range("H6:H6").Resize(r.Rows.Count).Value = r.Offset(, 8).Resize(, 1).Value 'Assembly
      Me.Range("I6:I6").Resize(r.Rows.Count).Value = r.Offset(, 9).Resize(, 1).Value 'Crust
      Me.Range("J6:J6").Resize(r.Rows.Count).Value = r.Offset(, 10).Resize(, 1).Value 'Damage Kms
            
'Spilt Road Category & Nos data saparate in 2 variable
      Name = r(1, 2): Firstname = Split(Name, " ")(0)
      LastName = Right(Name, Len(Name) - InStrRev(Name, " "))
      Me.Range("b3").Value = Firstname              'Road Category
      Me.Range("d3").Value = LastName               'Road Nos
      
'Data for Total Length, Start Chainage No. End Chainage Nos.
      TL = S(1, 6): STC = S(1, 3): ETC = S(1, 4)
      Me.Range("f3").Value = TL                     'Total Length
      Me.Range("H3").Value = STC                    'Start chainange
      Me.Range("j3").Value = ETC                    'End Chainage
      Cr = ActiveCell.Row
    Rows("6:105").Hidden = False
      i = Cr + 4
      
      Do While Sheets("Edit").Cells(i, "A") <> ""   'This loop use for hid unhide rows
        i = i + 1
      Loop
      i = i + 5
      j = 105
      If i <= 90 Then Rows(i + 5 & ":" & j).Hidden = True ' We hide rows if selected road details is <90 row
      Sheets("Edit").Protect Password:="san"
      Application.EnableEvents = True
   
   ElseIf Target.Address(0, 0) = "J108" And LCase(Trim(Target)) = "y" Then
      
      '==== WHEN WE PRESS Y THEN WORKING FOLLWING====


Dim YesOrNoAnswerToMessageBox As String
Dim QuestionToMessageBox As String


    QuestionToMessageBox = "Are you Sure You Want to Save Entered Road Record?"
    YesOrNoAnswerToMessageBox = MsgBox(QuestionToMessageBox, vbYesNo, "Confermation Yes or Not")


    If YesOrNoAnswerToMessageBox = vbYes Then
If Worksheets("Edit").Range("L107").Value = "Data Ok" Then
      Dim sh1 As Worksheet
      Dim pr1Sh As Worksheet                         'For Prarup-1
      Dim pr2Sh As Worksheet                         'For Prarup-2
      Dim found1 As Range, found2 As Long
      Dim CopyAry As Variant
      Dim DetRos As Long, EditRos As Long


Sheets("Prarup-1").Unprotect Password:="san"
Sheets("Prarup-2").Unprotect Password:="san"
      
      With ThisWorkbook
         Set sh1 = .Sheets("Edit")
         Set pr1Sh = .Sheets("prarup-1")
         Set pr2Sh = .Sheets("prarup-2")
      End With
      
      Application.EnableEvents = False
     
[B][COLOR=#ff0000]    With Sheets("Prarup-1")[/COLOR][/B]
[B][COLOR=#ff0000]    'set range road name find in Prarup-1 sheet (cell F2 value in Edit Sheet)[/COLOR][/B]
[B][COLOR=#ff0000]    Set Frng = .Range("B:B").Find(What:=Range("F2"), After:=Range("B5"), LookIn:=xlFormulas, _[/COLOR][/B]
[B][COLOR=#ff0000]        LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _[/COLOR][/B]
[B][COLOR=#ff0000]        MatchCase:=False, SearchFormat:=False)[/COLOR][/B]
[B][COLOR=#ff0000]    [/COLOR][/B]
[B][COLOR=#ff0000]    DetRos = .Range(Frng, Frng.End(xlDown).Offset(-1, 1)).Rows.Count 'Count Nos of Kms B4 edit[/COLOR][/B]
[B][COLOR=#ff0000]    EditRos = Range("a6", Range("a105").End(xlUp).Offset(0, 2)).Rows.Count 'Count Nos of Kms After edit[/COLOR][/B]
[B][COLOR=#ff0000]    [/COLOR][/B]
[B][COLOR=#ff0000]    If DetRos < EditRos Then 'if We ADD EXTRA kms detail (row) in Editing[/COLOR][/B]
[B][COLOR=#ff0000]        .Range(Frng.Offset(1, -1), Frng.Offset(EditRos - DetRos, 17)).Insert Shift:=xlDown[/COLOR][/B]
[B][COLOR=#ff0000]    [/COLOR][/B]
[B][COLOR=#ff0000]    ElseIf DetRos > EditRos Then  'if we REMOVE any kms details (row) in editing[/COLOR][/B]
[B][COLOR=#ff0000]    .Range(Frng.Offset(1, -1), Frng.Offset(DetRos - EditRos, 17)).Delete Shift:=xlUp[/COLOR][/B]
[B][COLOR=#ff0000]    [/COLOR][/B]
[B][COLOR=#ff0000]    End If[/COLOR][/B]
[B][COLOR=#ff0000]    'If no row add or no row remove in editing time[/COLOR][/B]
[B][COLOR=#ff0000]    .Range(Frng.Offset(0, 0), Frng.End(xlDown).Offset(-1, 17)).Value = Range(Range("A116"), Range("A215").End(xlUp).Offset(100, 17)).Value[/COLOR][/B]
[B][COLOR=#ff0000]    End With[/COLOR][/B]
    
    
    
    With Sheets("Prarup-2")
    'set range road name find in Prarup-2 sheet (cell F2 value in Edit Sheet)
    Set surng = .Range("C:C").Find(What:=Range("F2"), After:=Range("c4"), LookIn:=xlFormulas, _
        LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
        MatchCase:=False, SearchFormat:=False)
    .Range(surng.Offset(0, -1), surng.End(xlToRight).Offset(0, 123)).Value = Range("A112:EC112").Value
    End With
     
     Application.EnableEvents = False
        
        Target.Value = "N"
        Sheets("Edit").Unprotect Password:="san"
        Range("B3,D3,F3,H3,J3,F2:J2").ClearContents: Range("A6:j105").SpecialCells(2).ClearContents
        Sheets("Edit").Protect Password:="san"
        Application.EnableEvents = True
Range("a6").Select
Else
       MsgBox "Data Not Correct... See Row Number 67 for Errors!!" ' in 67 no row we check various entry correct or not correct
       End If
   


Else


   MsgBox "You Choose No .. so NO Record Post"
    End If
      Application.EnableEvents = True
   End If
End Sub

Above Code is working fine for me .. but few condition code not working as per my requirement.. whis is following..

if Road has single row data then code not working as per my requirement for eg Road-5, road-6 & road-8 Data.. not edit correctly...
Total Row remove after edit..

Pls help me for that.. i think we are not using offset function correctly or some change in finding Range in Prarup-1

We mark red color code where i think few change require..

We want to add sample file but can't find attach option..

Looking for +ve respose..

thanks & advance..

(Santosh)