سلام بسیار سپاسگزارم
یه مورد دیگه اینکه و قتی این کد رو (ذخیره) اجرا می کنم با تاخیر زیاد ذخیره می کنه علتش چی می تونه باشه؟
Sub Save()
Application.Calculation = xlCalculationManual
Dim Rng1 As Range
If Range("h8:h10").Text = "" Then
MsgBox "لطفا موارد ستاره دار تکميل گردد "
Exit Sub
ElseIf Not IsNumeric(Range("h7").Text) Then
MsgBox "کد پرسنلي به صورت عدد وارد شود "
Exit Sub
End If
'Copy data from sheet2 sheet
ActiveSheet.Unprotect
Application.ScreenUpdating = False
Sheets("sheet2").Select
Range("h7:h29").Select
Selection.Copy
Dim rngX As Range
Sheets("sheet2").Select
Set rngX = Worksheets("sheet3").Range("A1:A300").Find(Workshe ets("sheet2").Range("h7"), lookat:=xlPart)
If Not rngX Is Nothing Then
Sheets("sheet3").Select
Range(rngX.Address).Select
'Past data changes
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=True
Sheets("sheet2").Select
Range("h7:h29").Select
Selection.ClearContents
Range("h7").Select
MsgBox "اطلاعات جديد ذخيره شد"
Else
Sheets("sheet3").Select
Worksheets("sheet3").Cells(Rows.Count, "A").End(xlUp).Offset(1, 0).PasteSpecial , Transpose:=True
'ActiveSheet.Paste
ActiveCell.Offset(1).EntireRow.Insert
End If
Application.Calculation = xlCalculationAutomatic
End Sub
علاقه مندی ها (Bookmarks)