ExcelBanter

ExcelBanter (https://www.excelbanter.com/)
-   Excel Programming (https://www.excelbanter.com/excel-programming/)
-   -   On error resume next? question - problem (https://www.excelbanter.com/excel-programming/330653-error-resume-next-question-problem.html)

Andrzej
On error resume next? question - problem
 
I have a code:

Private Sub Worksheet_Change(ByVal Target As Range)
Dim szukana As Range
Dim Cecha As String
Dim bk As Workbook
Dim sh As Worksheet
Dim sh1 As Worksheet

Application.ScreenUpdating = False

If Not Application.Intersect(Columns("A:A"), Target) _
Is Nothing Then

Cecha = Target.Value
If Cecha = "" Then Exit Sub

On Error Resume Next
Set bk = Workbooks _
("D:\!Proj_temp_WSK\OPRZYRZADOWANIEv_6\NARZEDZIA\B AZA\katalog.xls")
On Error GoTo 0
If bk Is Nothing Then
If Err < 0 Then
Set bk = Workbooks.Open _
(Filename:="D:\!Proj_temp_WSK\OPRZYRZADOWANIEv_6\N ARZEDZIA\BAZA\katalog.xls"
)

End If

Set sh1 = bk.Worksheets(bk.Worksheets.Count)
For Each sh In bk.Worksheets
Set szukana = sh.Cells.Find(What:=Cecha, _
After:=ActiveCell, LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByColumns, _
SearchDirection:=xlNext, MatchCase:=False)
', _
' SearchFormat:=False)

If szukana Is Nothing Then
If sh.Name = sh1.Name Then
MsgBox "Szukana cecha """ & Cecha & """ nie została odnaleziona"
ActiveWorkbook.Close
Target.Value = ""
End If
Else

bk.Activate
sh.Activate
szukana.Activate
MsgBox "Szukana cecha """ & Cecha & """ została odnaleziona"
'ActiveWorkbook.Close
'ActiveCell.Value = Cecha
End If
Next sh

End If

Application.ScreenUpdating = True

end sub

I try to ptecect my code before situation that file:
("D:\!Proj_temp_WSK\OPRZYRZADOWANIEv_6\NARZEDZIA\B AZA\katalog.xls")
was earlier opened by differend user.
If this file was earlier opened, then I would like to my code don't open
again this file, just only search for "cecha"
else
i would like to my code open the file and search for "cecha"

Someone knows more practical solution ?
this my does not work

Andrzej

Tom Ogilvy
On error resume next? question - problem
 
On Error Resume Next
set bk = Workbooks("katalog.xls")
On Error goto 0
if bk is nothing then
Set bk = Workbooks.Open _
("D:\!Proj_temp_WSK\OPRZYRZADOWANIEv_6\NARZEDZIA\B AZA\katalog.xls")
End if

--
Regards,
Tom Ogilvy




"Andrzej" wrote in message
...
I have a code:

Private Sub Worksheet_Change(ByVal Target As Range)
Dim szukana As Range
Dim Cecha As String
Dim bk As Workbook
Dim sh As Worksheet
Dim sh1 As Worksheet

Application.ScreenUpdating = False

If Not Application.Intersect(Columns("A:A"), Target) _
Is Nothing Then

Cecha = Target.Value
If Cecha = "" Then Exit Sub

On Error Resume Next
Set bk = Workbooks _
("D:\!Proj_temp_WSK\OPRZYRZADOWANIEv_6\NARZEDZIA\B AZA\katalog.xls")
On Error GoTo 0
If bk Is Nothing Then
If Err < 0 Then
Set bk = Workbooks.Open _

(Filename:="D:\!Proj_temp_WSK\OPRZYRZADOWANIEv_6\N ARZEDZIA\BAZA\katalog.xls"
)

End If

Set sh1 = bk.Worksheets(bk.Worksheets.Count)
For Each sh In bk.Worksheets
Set szukana = sh.Cells.Find(What:=Cecha, _
After:=ActiveCell, LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByColumns, _
SearchDirection:=xlNext, MatchCase:=False)
', _
' SearchFormat:=False)

If szukana Is Nothing Then
If sh.Name = sh1.Name Then
MsgBox "Szukana cecha """ & Cecha & """ nie została odnaleziona"
ActiveWorkbook.Close
Target.Value = ""
End If
Else

bk.Activate
sh.Activate
szukana.Activate
MsgBox "Szukana cecha """ & Cecha & """ została odnaleziona"
'ActiveWorkbook.Close
'ActiveCell.Value = Cecha
End If
Next sh

End If

Application.ScreenUpdating = True

end sub

I try to ptecect my code before situation that file:
("D:\!Proj_temp_WSK\OPRZYRZADOWANIEv_6\NARZEDZIA\B AZA\katalog.xls")
was earlier opened by differend user.
If this file was earlier opened, then I would like to my code don't open
again this file, just only search for "cecha"
else
i would like to my code open the file and search for "cecha"

Someone knows more practical solution ?
this my does not work

Andrzej

Andrzej
On error resume next? question - problem
 
ok, but something is wrong.. because when find "cecha" displays
error: Aplication defined or object defined error.. (1004)

Mayby I made any mistakein filekatalog.xls?

Can you look at this code? (in file katalog)

Private Sub Workbook_BeforeClose(Cancel As Boolean)
Dim i, j, max, LiczCols As Integer

Dim bk As Workbook
Dim sh As Worksheet
Dim sh1 As Integer


If Not Me.Saved Then
Msg = "Czy zapisac zmiany w (save the change in)"
Msg = Msg & Me.Name & "?"
ans = MsgBox(Msg, vbQuestion + vbYesNoCancel)
Select Case ans
Case vbYes
Me.Save
Case vbNo
Me.Saved = True
Case vbCancel
Cancel = True
Exit Sub
End Select
End If
Call DeleteMenu

' blokada komorek wpisanych t(he blockade of full cells )

sh1 = ActiveWorkbook.Worksheets.Count

Application.ScreenUpdating = False

For j = 1 To sh1

Sheets(j).Activate
Sheets(j).Unprotect
'max = Range(Cells(1, 1), Selection.End _
(xlToRight)).Count
max = 1
'liczba kolumn wypełnionych
Cells(1, 1).Select
' okreslenie zakresu
LiczCols = Range(Selection, Selection.End _
(xlToRight)).Count
For i = 1 To LiczCols
If Range(Selection, Selection.End _
(xlDown)).Count max _
Then max = Range _
(Selection, Selection.End(xlDown)).Count
Cells(1, i).Select ' -in this line is ERROR
Next i
' Cells(10, 1) = "A1:A" & max
' zaznacz zakres i zablokuj niepuste komorki
Range("A1:A" & max).Select
Range(Selection, Selection.End _
(xlToRight)).Select
'Selection.Locked = True
For Each cell In Selection
If cell < "" Then cell.Locked = True
If cell = "" Then cell.Locked = False

Next cell

Sheets(j).Protect

Next j

Application.ScreenUpdating = True
End Sub





Użytkownik "Tom Ogilvy" napisał w wiadomości
...
On Error Resume Next
set bk = Workbooks("katalog.xls")
On Error goto 0
if bk is nothing then
Set bk = Workbooks.Open _
("D:\!Proj_temp_WSK\OPRZYRZADOWANIEv_6\NARZEDZIA\B AZA\katalog.xls")
End if

--
Regards,
Tom Ogilvy




"Andrzej" wrote in message
...
I have a code:

Private Sub Worksheet_Change(ByVal Target As Range)
Dim szukana As Range
Dim Cecha As String
Dim bk As Workbook
Dim sh As Worksheet
Dim sh1 As Worksheet

Application.ScreenUpdating = False

If Not Application.Intersect(Columns("A:A"), Target) _
Is Nothing Then

Cecha = Target.Value
If Cecha = "" Then Exit Sub

On Error Resume Next
Set bk = Workbooks _
("D:\!Proj_temp_WSK\OPRZYRZADOWANIEv_6\NARZEDZIA\B AZA\katalog.xls")
On Error GoTo 0
If bk Is Nothing Then
If Err < 0 Then
Set bk = Workbooks.Open _


(Filename:="D:\!Proj_temp_WSK\OPRZYRZADOWANIEv_6\N ARZEDZIA\BAZA\katalog.xls"
)

End If

Set sh1 = bk.Worksheets(bk.Worksheets.Count)
For Each sh In bk.Worksheets
Set szukana = sh.Cells.Find(What:=Cecha, _
After:=ActiveCell, LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByColumns, _
SearchDirection:=xlNext, MatchCase:=False)
', _
' SearchFormat:=False)

If szukana Is Nothing Then
If sh.Name = sh1.Name Then
MsgBox "Szukana cecha """ & Cecha & """ nie została odnaleziona"
ActiveWorkbook.Close
Target.Value = ""
End If
Else

bk.Activate
sh.Activate
szukana.Activate
MsgBox "Szukana cecha """ & Cecha & """ została odnaleziona"
'ActiveWorkbook.Close
'ActiveCell.Value = Cecha
End If
Next sh

End If

Application.ScreenUpdating = True

end sub

I try to ptecect my code before situation that file:
("D:\!Proj_temp_WSK\OPRZYRZADOWANIEv_6\NARZEDZIA\B AZA\katalog.xls")
was earlier opened by differend user.
If this file was earlier opened, then I would like to my code don't
open
again this file, just only search for "cecha"
else
i would like to my code open the file and search for "cecha"

Someone knows more practical solution ?
this my does not work

Andrzej

Tom Ogilvy
On error resume next? question - problem
 
If by

If cell = "" Then cell.Locked = False

you want to unlock empty cells then


Private Sub Workbook_BeforeClose(Cancel As Boolean)
Dim i as long, j as Long, max as Long
Dim LiczCols As Long

Dim bk As Workbook
Dim sh As Worksheet
Dim sh1 As Integer
Dim rng as Range

If Not Me.Saved Then
Msg = "Czy zapisac zmiany w (save the change in)"
Msg = Msg & Me.Name & "?"
ans = MsgBox(Msg, vbQuestion + vbYesNoCancel)
Select Case ans
Case vbYes
Me.Save
Case vbNo
Me.Saved = True
Case vbCancel
Cancel = True
Exit Sub
End Select
End If
Call DeleteMenu

' blokada komorek wpisanych t(he blockade of full cells )

sh1 = ActiveWorkbook.Worksheets.Count

Application.ScreenUpdating = False

For j = 1 To sh1

Sheets(j).Activate
Sheets(j).Unprotect
cells.Locked = True
set rng = nothing
On error resume Next
set rng = cells.SpecialCells(xlBlanks)
On Error goto 0
if not rng is nothing then
rng.Locked = False
end if
Sheets(j).Protect

Next j

Application.ScreenUpdating = True
End Sub

--
Regards,
Tom Ogilvy

"Andrzej" wrote in message
...
ok, but something is wrong.. because when find "cecha" displays
error: Aplication defined or object defined error.. (1004)

Mayby I made any mistakein filekatalog.xls?

Can you look at this code? (in file katalog)

Private Sub Workbook_BeforeClose(Cancel As Boolean)
Dim i, j, max, LiczCols As Integer

Dim bk As Workbook
Dim sh As Worksheet
Dim sh1 As Integer


If Not Me.Saved Then
Msg = "Czy zapisac zmiany w (save the change in)"
Msg = Msg & Me.Name & "?"
ans = MsgBox(Msg, vbQuestion + vbYesNoCancel)
Select Case ans
Case vbYes
Me.Save
Case vbNo
Me.Saved = True
Case vbCancel
Cancel = True
Exit Sub
End Select
End If
Call DeleteMenu

' blokada komorek wpisanych t(he blockade of full cells )

sh1 = ActiveWorkbook.Worksheets.Count

Application.ScreenUpdating = False

For j = 1 To sh1

Sheets(j).Activate
Sheets(j).Unprotect
'max = Range(Cells(1, 1), Selection.End _
(xlToRight)).Count
max = 1
'liczba kolumn wypełnionych
Cells(1, 1).Select
' okreslenie zakresu
LiczCols = Range(Selection, Selection.End _
(xlToRight)).Count
For i = 1 To LiczCols
If Range(Selection, Selection.End _
(xlDown)).Count max _
Then max = Range _
(Selection, Selection.End(xlDown)).Count
Cells(1, i).Select ' -in this line is ERROR
Next i
' Cells(10, 1) = "A1:A" & max
' zaznacz zakres i zablokuj niepuste komorki
Range("A1:A" & max).Select
Range(Selection, Selection.End _
(xlToRight)).Select
'Selection.Locked = True
For Each cell In Selection
If cell < "" Then cell.Locked = True
If cell = "" Then cell.Locked = False

Next cell

Sheets(j).Protect

Next j

Application.ScreenUpdating = True
End Sub





Użytkownik "Tom Ogilvy" napisał w wiadomości
...
On Error Resume Next
set bk = Workbooks("katalog.xls")
On Error goto 0
if bk is nothing then
Set bk = Workbooks.Open _

("D:\!Proj_temp_WSK\OPRZYRZADOWANIEv_6\NARZEDZIA\B AZA\katalog.xls")
End if

--
Regards,
Tom Ogilvy




"Andrzej" wrote in message
...
I have a code:

Private Sub Worksheet_Change(ByVal Target As Range)
Dim szukana As Range
Dim Cecha As String
Dim bk As Workbook
Dim sh As Worksheet
Dim sh1 As Worksheet

Application.ScreenUpdating = False

If Not Application.Intersect(Columns("A:A"), Target) _
Is Nothing Then

Cecha = Target.Value
If Cecha = "" Then Exit Sub

On Error Resume Next
Set bk = Workbooks _
("D:\!Proj_temp_WSK\OPRZYRZADOWANIEv_6\NARZEDZIA\B AZA\katalog.xls")
On Error GoTo 0
If bk Is Nothing Then
If Err < 0 Then
Set bk = Workbooks.Open _



(Filename:="D:\!Proj_temp_WSK\OPRZYRZADOWANIEv_6\N ARZEDZIA\BAZA\katalog.xls"
)

End If

Set sh1 = bk.Worksheets(bk.Worksheets.Count)
For Each sh In bk.Worksheets
Set szukana = sh.Cells.Find(What:=Cecha, _
After:=ActiveCell, LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByColumns, _
SearchDirection:=xlNext, MatchCase:=False)
', _
' SearchFormat:=False)

If szukana Is Nothing Then
If sh.Name = sh1.Name Then
MsgBox "Szukana cecha """ & Cecha & """ nie została odnaleziona"
ActiveWorkbook.Close
Target.Value = ""
End If
Else

bk.Activate
sh.Activate
szukana.Activate
MsgBox "Szukana cecha """ & Cecha & """ została odnaleziona"
'ActiveWorkbook.Close
'ActiveCell.Value = Cecha
End If
Next sh

End If

Application.ScreenUpdating = True

end sub

I try to ptecect my code before situation that file:
("D:\!Proj_temp_WSK\OPRZYRZADOWANIEv_6\NARZEDZIA\B AZA\katalog.xls")
was earlier opened by differend user.
If this file was earlier opened, then I would like to my code don't
open
again this file, just only search for "cecha"
else
i would like to my code open the file and search for "cecha"

Someone knows more practical solution ?
this my does not work

Andrzej

Andrzej
On error resume next? question - problem
 
Work ok...,but is it different problem.

I have 3 catalogues:
NARZEDZIA,
PRZYRZADY,
SPRAWDZIANY,

and in every of them is two files about the same names, Exactly:
katalog.xls and baza_cech.xls

What happend if some person opened katalog.xls from NARZEDZIA and at the
same time other person opened katalog.xls from ..for example SPRAWDZIANY...

mistake step out??? and if not... of which file will be search??

Will the change of name of files be only solution?

for example:

katalog_s.xls in SPRAWDZIANY

katalog_p.xls in PRZYRZADY

katalog_n.xls in NARZEDZIA

What do you think?

Pozdrowienia,

Andrzej







Użytkownik "Tom Ogilvy" napisał w wiadomości
...
If by

If cell = "" Then cell.Locked = False

you want to unlock empty cells then


Private Sub Workbook_BeforeClose(Cancel As Boolean)
Dim i as long, j as Long, max as Long
Dim LiczCols As Long

Dim bk As Workbook
Dim sh As Worksheet
Dim sh1 As Integer
Dim rng as Range

If Not Me.Saved Then
Msg = "Czy zapisac zmiany w (save the change in)"
Msg = Msg & Me.Name & "?"
ans = MsgBox(Msg, vbQuestion + vbYesNoCancel)
Select Case ans
Case vbYes
Me.Save
Case vbNo
Me.Saved = True
Case vbCancel
Cancel = True
Exit Sub
End Select
End If
Call DeleteMenu

' blokada komorek wpisanych t(he blockade of full cells )

sh1 = ActiveWorkbook.Worksheets.Count

Application.ScreenUpdating = False

For j = 1 To sh1

Sheets(j).Activate
Sheets(j).Unprotect
cells.Locked = True
set rng = nothing
On error resume Next
set rng = cells.SpecialCells(xlBlanks)
On Error goto 0
if not rng is nothing then
rng.Locked = False
end if
Sheets(j).Protect

Next j

Application.ScreenUpdating = True
End Sub

--
Regards,
Tom Ogilvy

"Andrzej" wrote in message
...
ok, but something is wrong.. because when find "cecha" displays
error: Aplication defined or object defined error.. (1004)

Mayby I made any mistakein filekatalog.xls?

Can you look at this code? (in file katalog)

Private Sub Workbook_BeforeClose(Cancel As Boolean)
Dim i, j, max, LiczCols As Integer

Dim bk As Workbook
Dim sh As Worksheet
Dim sh1 As Integer


If Not Me.Saved Then
Msg = "Czy zapisac zmiany w (save the change in)"
Msg = Msg & Me.Name & "?"
ans = MsgBox(Msg, vbQuestion + vbYesNoCancel)
Select Case ans
Case vbYes
Me.Save
Case vbNo
Me.Saved = True
Case vbCancel
Cancel = True
Exit Sub
End Select
End If
Call DeleteMenu

' blokada komorek wpisanych t(he blockade of full cells )

sh1 = ActiveWorkbook.Worksheets.Count

Application.ScreenUpdating = False

For j = 1 To sh1

Sheets(j).Activate
Sheets(j).Unprotect
'max = Range(Cells(1, 1), Selection.End _
(xlToRight)).Count
max = 1
'liczba kolumn wypełnionych
Cells(1, 1).Select
' okreslenie zakresu
LiczCols = Range(Selection, Selection.End _
(xlToRight)).Count
For i = 1 To LiczCols
If Range(Selection, Selection.End _
(xlDown)).Count max _
Then max = Range _
(Selection, Selection.End(xlDown)).Count
Cells(1, i).Select ' -in this line is ERROR
Next i
' Cells(10, 1) = "A1:A" & max
' zaznacz zakres i zablokuj niepuste komorki
Range("A1:A" & max).Select
Range(Selection, Selection.End _
(xlToRight)).Select
'Selection.Locked = True
For Each cell In Selection
If cell < "" Then cell.Locked = True
If cell = "" Then cell.Locked = False

Next cell

Sheets(j).Protect

Next j

Application.ScreenUpdating = True
End Sub





Użytkownik "Tom Ogilvy" napisał w wiadomości
...
On Error Resume Next
set bk = Workbooks("katalog.xls")
On Error goto 0
if bk is nothing then
Set bk = Workbooks.Open _

("D:\!Proj_temp_WSK\OPRZYRZADOWANIEv_6\NARZEDZIA\B AZA\katalog.xls")
End if

--
Regards,
Tom Ogilvy




"Andrzej" wrote in message
...
I have a code:

Private Sub Worksheet_Change(ByVal Target As Range)
Dim szukana As Range
Dim Cecha As String
Dim bk As Workbook
Dim sh As Worksheet
Dim sh1 As Worksheet

Application.ScreenUpdating = False

If Not Application.Intersect(Columns("A:A"), Target) _
Is Nothing Then

Cecha = Target.Value
If Cecha = "" Then Exit Sub

On Error Resume Next
Set bk = Workbooks _
("D:\!Proj_temp_WSK\OPRZYRZADOWANIEv_6\NARZEDZIA\B AZA\katalog.xls")
On Error GoTo 0
If bk Is Nothing Then
If Err < 0 Then
Set bk = Workbooks.Open _




(Filename:="D:\!Proj_temp_WSK\OPRZYRZADOWANIEv_6\N ARZEDZIA\BAZA\katalog.xls"
)

End If

Set sh1 = bk.Worksheets(bk.Worksheets.Count)
For Each sh In bk.Worksheets
Set szukana = sh.Cells.Find(What:=Cecha, _
After:=ActiveCell, LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByColumns, _
SearchDirection:=xlNext, MatchCase:=False)
', _
' SearchFormat:=False)

If szukana Is Nothing Then
If sh.Name = sh1.Name Then
MsgBox "Szukana cecha """ & Cecha & """ nie została odnaleziona"
ActiveWorkbook.Close
Target.Value = ""
End If
Else

bk.Activate
sh.Activate
szukana.Activate
MsgBox "Szukana cecha """ & Cecha & """ została odnaleziona"
'ActiveWorkbook.Close
'ActiveCell.Value = Cecha
End If
Next sh

End If

Application.ScreenUpdating = True

end sub

I try to ptecect my code before situation that file:
("D:\!Proj_temp_WSK\OPRZYRZADOWANIEv_6\NARZEDZIA\B AZA\katalog.xls")
was earlier opened by differend user.
If this file was earlier opened, then I would like to my code
don't
open
again this file, just only search for "cecha"
else
i would like to my code open the file and search for "cecha"

Someone knows more practical solution ?
this my does not work

Andrzej

Tom Ogilvy
On error resume next? question - problem
 
ActiveWorkbook.FullName

will tell you the fully qualified path of the workbook. Perhaps that will
help you decide

sFullName = Bk.FullName
sLtr = ""
if inStr(1,sFullName,"Narzedzia",vbTextCompare) then
sLtr = "N"
else if instr(1,sFullName,"Sprawdziany",vbTextCompare) then
sLtr = "S"
else if instr(1,sFullName,"PRZYRZADY",vbTextCompare) then
sLtr = "P"
End if

obviously using sLtr is just to illustrate doing something in the If
statement.

--
Regards,
Tom Ogilvy


"Andrzej" wrote in message
...
Work ok...,but is it different problem.

I have 3 catalogues:
NARZEDZIA,
PRZYRZADY,
SPRAWDZIANY,

and in every of them is two files about the same names, Exactly:
katalog.xls and baza_cech.xls

What happend if some person opened katalog.xls from NARZEDZIA and at the
same time other person opened katalog.xls from ..for example
SPRAWDZIANY...

mistake step out??? and if not... of which file will be search??

Will the change of name of files be only solution?

for example:

katalog_s.xls in SPRAWDZIANY

katalog_p.xls in PRZYRZADY

katalog_n.xls in NARZEDZIA

What do you think?

Pozdrowienia,

Andrzej







Użytkownik "Tom Ogilvy" napisał w wiadomości
...
If by

If cell = "" Then cell.Locked = False

you want to unlock empty cells then


Private Sub Workbook_BeforeClose(Cancel As Boolean)
Dim i as long, j as Long, max as Long
Dim LiczCols As Long

Dim bk As Workbook
Dim sh As Worksheet
Dim sh1 As Integer
Dim rng as Range

If Not Me.Saved Then
Msg = "Czy zapisac zmiany w (save the change in)"
Msg = Msg & Me.Name & "?"
ans = MsgBox(Msg, vbQuestion + vbYesNoCancel)
Select Case ans
Case vbYes
Me.Save
Case vbNo
Me.Saved = True
Case vbCancel
Cancel = True
Exit Sub
End Select
End If
Call DeleteMenu

' blokada komorek wpisanych t(he blockade of full cells )

sh1 = ActiveWorkbook.Worksheets.Count

Application.ScreenUpdating = False

For j = 1 To sh1

Sheets(j).Activate
Sheets(j).Unprotect
cells.Locked = True
set rng = nothing
On error resume Next
set rng = cells.SpecialCells(xlBlanks)
On Error goto 0
if not rng is nothing then
rng.Locked = False
end if
Sheets(j).Protect

Next j

Application.ScreenUpdating = True
End Sub

--
Regards,
Tom Ogilvy

"Andrzej" wrote in message
...
ok, but something is wrong.. because when find "cecha" displays
error: Aplication defined or object defined error.. (1004)

Mayby I made any mistakein filekatalog.xls?

Can you look at this code? (in file katalog)

Private Sub Workbook_BeforeClose(Cancel As Boolean)
Dim i, j, max, LiczCols As Integer

Dim bk As Workbook
Dim sh As Worksheet
Dim sh1 As Integer


If Not Me.Saved Then
Msg = "Czy zapisac zmiany w (save the change in)"
Msg = Msg & Me.Name & "?"
ans = MsgBox(Msg, vbQuestion + vbYesNoCancel)
Select Case ans
Case vbYes
Me.Save
Case vbNo
Me.Saved = True
Case vbCancel
Cancel = True
Exit Sub
End Select
End If
Call DeleteMenu

' blokada komorek wpisanych t(he blockade of full cells )

sh1 = ActiveWorkbook.Worksheets.Count

Application.ScreenUpdating = False

For j = 1 To sh1

Sheets(j).Activate
Sheets(j).Unprotect
'max = Range(Cells(1, 1), Selection.End _
(xlToRight)).Count
max = 1
'liczba kolumn wypełnionych
Cells(1, 1).Select
' okreslenie zakresu
LiczCols = Range(Selection, Selection.End _
(xlToRight)).Count
For i = 1 To LiczCols
If Range(Selection, Selection.End _
(xlDown)).Count max _
Then max = Range _
(Selection, Selection.End(xlDown)).Count
Cells(1, i).Select ' -in this line is ERROR
Next i
' Cells(10, 1) = "A1:A" & max
' zaznacz zakres i zablokuj niepuste komorki
Range("A1:A" & max).Select
Range(Selection, Selection.End _
(xlToRight)).Select
'Selection.Locked = True
For Each cell In Selection
If cell < "" Then cell.Locked = True
If cell = "" Then cell.Locked = False

Next cell

Sheets(j).Protect

Next j

Application.ScreenUpdating = True
End Sub





Użytkownik "Tom Ogilvy" napisał w wiadomości
...
On Error Resume Next
set bk = Workbooks("katalog.xls")
On Error goto 0
if bk is nothing then
Set bk = Workbooks.Open _

("D:\!Proj_temp_WSK\OPRZYRZADOWANIEv_6\NARZEDZIA\B AZA\katalog.xls")
End if

--
Regards,
Tom Ogilvy




"Andrzej" wrote in message
...
I have a code:

Private Sub Worksheet_Change(ByVal Target As Range)
Dim szukana As Range
Dim Cecha As String
Dim bk As Workbook
Dim sh As Worksheet
Dim sh1 As Worksheet

Application.ScreenUpdating = False

If Not Application.Intersect(Columns("A:A"), Target) _
Is Nothing Then

Cecha = Target.Value
If Cecha = "" Then Exit Sub

On Error Resume Next
Set bk = Workbooks _

("D:\!Proj_temp_WSK\OPRZYRZADOWANIEv_6\NARZEDZIA\B AZA\katalog.xls")
On Error GoTo 0
If bk Is Nothing Then
If Err < 0 Then
Set bk = Workbooks.Open _





(Filename:="D:\!Proj_temp_WSK\OPRZYRZADOWANIEv_6\N ARZEDZIA\BAZA\katalog.xls"
)

End If

Set sh1 = bk.Worksheets(bk.Worksheets.Count)
For Each sh In bk.Worksheets
Set szukana = sh.Cells.Find(What:=Cecha, _
After:=ActiveCell, LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByColumns, _
SearchDirection:=xlNext, MatchCase:=False)
', _
' SearchFormat:=False)

If szukana Is Nothing Then
If sh.Name = sh1.Name Then
MsgBox "Szukana cecha """ & Cecha & """ nie została
odnaleziona"
ActiveWorkbook.Close
Target.Value = ""
End If
Else

bk.Activate
sh.Activate
szukana.Activate
MsgBox "Szukana cecha """ & Cecha & """ została
odnaleziona"
'ActiveWorkbook.Close
'ActiveCell.Value = Cecha
End If
Next sh

End If

Application.ScreenUpdating = True

end sub

I try to ptecect my code before situation that file:

("D:\!Proj_temp_WSK\OPRZYRZADOWANIEv_6\NARZEDZIA\B AZA\katalog.xls")
was earlier opened by differend user.
If this file was earlier opened, then I would like to my code
don't
open
again this file, just only search for "cecha"
else
i would like to my code open the file and search for "cecha"

Someone knows more practical solution ?
this my does not work

Andrzej

Andrzej
On error resume next? question - problem
 
your code didn' t work corectly..

I need:

If cells are empty then is unlock
and if cells.value <"" then i wont to lock this cells in every sheets..



Użytkownik "Tom Ogilvy" napisał w wiadomości
...
If by

If cell = "" Then cell.Locked = False

you want to unlock empty cells then


Private Sub Workbook_BeforeClose(Cancel As Boolean)
Dim i as long, j as Long, max as Long
Dim LiczCols As Long

Dim bk As Workbook
Dim sh As Worksheet
Dim sh1 As Integer
Dim rng as Range

If Not Me.Saved Then
Msg = "Czy zapisac zmiany w (save the change in)"
Msg = Msg & Me.Name & "?"
ans = MsgBox(Msg, vbQuestion + vbYesNoCancel)
Select Case ans
Case vbYes
Me.Save
Case vbNo
Me.Saved = True
Case vbCancel
Cancel = True
Exit Sub
End Select
End If
Call DeleteMenu

' blokada komorek wpisanych t(he blockade of full cells )

sh1 = ActiveWorkbook.Worksheets.Count

Application.ScreenUpdating = False

For j = 1 To sh1

Sheets(j).Activate
Sheets(j).Unprotect
cells.Locked = True
set rng = nothing
On error resume Next
set rng = cells.SpecialCells(xlBlanks)
On Error goto 0
if not rng is nothing then
rng.Locked = False
end if
Sheets(j).Protect

Next j

Application.ScreenUpdating = True
End Sub

--
Regards,
Tom Ogilvy

"Andrzej" wrote in message
...
ok, but something is wrong.. because when find "cecha" displays
error: Aplication defined or object defined error.. (1004)

Mayby I made any mistakein filekatalog.xls?

Can you look at this code? (in file katalog)

Private Sub Workbook_BeforeClose(Cancel As Boolean)
Dim i, j, max, LiczCols As Integer

Dim bk As Workbook
Dim sh As Worksheet
Dim sh1 As Integer


If Not Me.Saved Then
Msg = "Czy zapisac zmiany w (save the change in)"
Msg = Msg & Me.Name & "?"
ans = MsgBox(Msg, vbQuestion + vbYesNoCancel)
Select Case ans
Case vbYes
Me.Save
Case vbNo
Me.Saved = True
Case vbCancel
Cancel = True
Exit Sub
End Select
End If
Call DeleteMenu

' blokada komorek wpisanych t(he blockade of full cells )

sh1 = ActiveWorkbook.Worksheets.Count

Application.ScreenUpdating = False

For j = 1 To sh1

Sheets(j).Activate
Sheets(j).Unprotect
'max = Range(Cells(1, 1), Selection.End _
(xlToRight)).Count
max = 1
'liczba kolumn wypełnionych
Cells(1, 1).Select
' okreslenie zakresu
LiczCols = Range(Selection, Selection.End _
(xlToRight)).Count
For i = 1 To LiczCols
If Range(Selection, Selection.End _
(xlDown)).Count max _
Then max = Range _
(Selection, Selection.End(xlDown)).Count
Cells(1, i).Select ' -in this line is ERROR
Next i
' Cells(10, 1) = "A1:A" & max
' zaznacz zakres i zablokuj niepuste komorki
Range("A1:A" & max).Select
Range(Selection, Selection.End _
(xlToRight)).Select
'Selection.Locked = True
For Each cell In Selection
If cell < "" Then cell.Locked = True
If cell = "" Then cell.Locked = False

Next cell

Sheets(j).Protect

Next j

Application.ScreenUpdating = True
End Sub





Użytkownik "Tom Ogilvy" napisał w wiadomości
...
On Error Resume Next
set bk = Workbooks("katalog.xls")
On Error goto 0
if bk is nothing then
Set bk = Workbooks.Open _

("D:\!Proj_temp_WSK\OPRZYRZADOWANIEv_6\NARZEDZIA\B AZA\katalog.xls")
End if

--
Regards,
Tom Ogilvy




"Andrzej" wrote in message
...
I have a code:

Private Sub Worksheet_Change(ByVal Target As Range)
Dim szukana As Range
Dim Cecha As String
Dim bk As Workbook
Dim sh As Worksheet
Dim sh1 As Worksheet

Application.ScreenUpdating = False

If Not Application.Intersect(Columns("A:A"), Target) _
Is Nothing Then

Cecha = Target.Value
If Cecha = "" Then Exit Sub

On Error Resume Next
Set bk = Workbooks _
("D:\!Proj_temp_WSK\OPRZYRZADOWANIEv_6\NARZEDZIA\B AZA\katalog.xls")
On Error GoTo 0
If bk Is Nothing Then
If Err < 0 Then
Set bk = Workbooks.Open _




(Filename:="D:\!Proj_temp_WSK\OPRZYRZADOWANIEv_6\N ARZEDZIA\BAZA\katalog.xls"
)

End If

Set sh1 = bk.Worksheets(bk.Worksheets.Count)
For Each sh In bk.Worksheets
Set szukana = sh.Cells.Find(What:=Cecha, _
After:=ActiveCell, LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByColumns, _
SearchDirection:=xlNext, MatchCase:=False)
', _
' SearchFormat:=False)

If szukana Is Nothing Then
If sh.Name = sh1.Name Then
MsgBox "Szukana cecha """ & Cecha & """ nie została odnaleziona"
ActiveWorkbook.Close
Target.Value = ""
End If
Else

bk.Activate
sh.Activate
szukana.Activate
MsgBox "Szukana cecha """ & Cecha & """ została odnaleziona"
'ActiveWorkbook.Close
'ActiveCell.Value = Cecha
End If
Next sh

End If

Application.ScreenUpdating = True

end sub

I try to ptecect my code before situation that file:
("D:\!Proj_temp_WSK\OPRZYRZADOWANIEv_6\NARZEDZIA\B AZA\katalog.xls")
was earlier opened by differend user.
If this file was earlier opened, then I would like to my code
don't
open
again this file, just only search for "cecha"
else
i would like to my code open the file and search for "cecha"

Someone knows more practical solution ?
this my does not work

Andrzej

Tom Ogilvy
On error resume next? question - problem
 
That is what the code does (based on the assumptions I stated). Sorry if
you can't get it to work for you.

--
Regards,
Tom Ogilvy


"Andrzej" wrote in message
...
your code didn' t work corectly..

I need:

If cells are empty then is unlock
and if cells.value <"" then i wont to lock this cells in every sheets..



Użytkownik "Tom Ogilvy" napisał w wiadomości
...
If by

If cell = "" Then cell.Locked = False

you want to unlock empty cells then


Private Sub Workbook_BeforeClose(Cancel As Boolean)
Dim i as long, j as Long, max as Long
Dim LiczCols As Long

Dim bk As Workbook
Dim sh As Worksheet
Dim sh1 As Integer
Dim rng as Range

If Not Me.Saved Then
Msg = "Czy zapisac zmiany w (save the change in)"
Msg = Msg & Me.Name & "?"
ans = MsgBox(Msg, vbQuestion + vbYesNoCancel)
Select Case ans
Case vbYes
Me.Save
Case vbNo
Me.Saved = True
Case vbCancel
Cancel = True
Exit Sub
End Select
End If
Call DeleteMenu

' blokada komorek wpisanych t(he blockade of full cells )

sh1 = ActiveWorkbook.Worksheets.Count

Application.ScreenUpdating = False

For j = 1 To sh1

Sheets(j).Activate
Sheets(j).Unprotect
cells.Locked = True
set rng = nothing
On error resume Next
set rng = cells.SpecialCells(xlBlanks)
On Error goto 0
if not rng is nothing then
rng.Locked = False
end if
Sheets(j).Protect

Next j

Application.ScreenUpdating = True
End Sub

--
Regards,
Tom Ogilvy

"Andrzej" wrote in message
...
ok, but something is wrong.. because when find "cecha" displays
error: Aplication defined or object defined error.. (1004)

Mayby I made any mistakein filekatalog.xls?

Can you look at this code? (in file katalog)

Private Sub Workbook_BeforeClose(Cancel As Boolean)
Dim i, j, max, LiczCols As Integer

Dim bk As Workbook
Dim sh As Worksheet
Dim sh1 As Integer


If Not Me.Saved Then
Msg = "Czy zapisac zmiany w (save the change in)"
Msg = Msg & Me.Name & "?"
ans = MsgBox(Msg, vbQuestion + vbYesNoCancel)
Select Case ans
Case vbYes
Me.Save
Case vbNo
Me.Saved = True
Case vbCancel
Cancel = True
Exit Sub
End Select
End If
Call DeleteMenu

' blokada komorek wpisanych t(he blockade of full cells )

sh1 = ActiveWorkbook.Worksheets.Count

Application.ScreenUpdating = False

For j = 1 To sh1

Sheets(j).Activate
Sheets(j).Unprotect
'max = Range(Cells(1, 1), Selection.End _
(xlToRight)).Count
max = 1
'liczba kolumn wypełnionych
Cells(1, 1).Select
' okreslenie zakresu
LiczCols = Range(Selection, Selection.End _
(xlToRight)).Count
For i = 1 To LiczCols
If Range(Selection, Selection.End _
(xlDown)).Count max _
Then max = Range _
(Selection, Selection.End(xlDown)).Count
Cells(1, i).Select ' -in this line is ERROR
Next i
' Cells(10, 1) = "A1:A" & max
' zaznacz zakres i zablokuj niepuste komorki
Range("A1:A" & max).Select
Range(Selection, Selection.End _
(xlToRight)).Select
'Selection.Locked = True
For Each cell In Selection
If cell < "" Then cell.Locked = True
If cell = "" Then cell.Locked = False

Next cell

Sheets(j).Protect

Next j

Application.ScreenUpdating = True
End Sub





Użytkownik "Tom Ogilvy" napisał w wiadomości
...
On Error Resume Next
set bk = Workbooks("katalog.xls")
On Error goto 0
if bk is nothing then
Set bk = Workbooks.Open _

("D:\!Proj_temp_WSK\OPRZYRZADOWANIEv_6\NARZEDZIA\B AZA\katalog.xls")
End if

--
Regards,
Tom Ogilvy




"Andrzej" wrote in message
...
I have a code:

Private Sub Worksheet_Change(ByVal Target As Range)
Dim szukana As Range
Dim Cecha As String
Dim bk As Workbook
Dim sh As Worksheet
Dim sh1 As Worksheet

Application.ScreenUpdating = False

If Not Application.Intersect(Columns("A:A"), Target) _
Is Nothing Then

Cecha = Target.Value
If Cecha = "" Then Exit Sub

On Error Resume Next
Set bk = Workbooks _

("D:\!Proj_temp_WSK\OPRZYRZADOWANIEv_6\NARZEDZIA\B AZA\katalog.xls")
On Error GoTo 0
If bk Is Nothing Then
If Err < 0 Then
Set bk = Workbooks.Open _





(Filename:="D:\!Proj_temp_WSK\OPRZYRZADOWANIEv_6\N ARZEDZIA\BAZA\katalog.xls"
)

End If

Set sh1 = bk.Worksheets(bk.Worksheets.Count)
For Each sh In bk.Worksheets
Set szukana = sh.Cells.Find(What:=Cecha, _
After:=ActiveCell, LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByColumns, _
SearchDirection:=xlNext, MatchCase:=False)
', _
' SearchFormat:=False)

If szukana Is Nothing Then
If sh.Name = sh1.Name Then
MsgBox "Szukana cecha """ & Cecha & """ nie została
odnaleziona"
ActiveWorkbook.Close
Target.Value = ""
End If
Else

bk.Activate
sh.Activate
szukana.Activate
MsgBox "Szukana cecha """ & Cecha & """ została
odnaleziona"
'ActiveWorkbook.Close
'ActiveCell.Value = Cecha
End If
Next sh

End If

Application.ScreenUpdating = True

end sub

I try to ptecect my code before situation that file:

("D:\!Proj_temp_WSK\OPRZYRZADOWANIEv_6\NARZEDZIA\B AZA\katalog.xls")
was earlier opened by differend user.
If this file was earlier opened, then I would like to my code
don't
open
again this file, just only search for "cecha"
else
i would like to my code open the file and search for "cecha"

Someone knows more practical solution ?
this my does not work

Andrzej

Andrzej
On error resume next? question - problem
 
Hi, Tom

I do not know why... but cells be blocked variously ( I would say that
accidentally). Sometimes every sheet, sometimes only one column...
Surely will you give this strange ? but it yes.

maybe therefore, that in my project are more options... and something
"bites" maybe? For example: the adding for administrator of file the new
menu (and his removal after close)

I think that only solution to this work correctly (because it can we do not
understand each other) it is.. if you saw this project on live.

I do not know I should ask about this? but I will ask..

Could I send my project on your priv??

Pozdrawiam,

Andrzej



Użytkownik "Tom Ogilvy" napisał w wiadomości
...
That is what the code does (based on the assumptions I stated). Sorry if
you can't get it to work for you.

--
Regards,
Tom Ogilvy


"Andrzej" wrote in message
...
your code didn' t work corectly..

I need:

If cells are empty then is unlock
and if cells.value <"" then i wont to lock this cells in every
sheets..



Użytkownik "Tom Ogilvy" napisał w wiadomości
...
If by

If cell = "" Then cell.Locked = False

you want to unlock empty cells then


Private Sub Workbook_BeforeClose(Cancel As Boolean)
Dim i as long, j as Long, max as Long
Dim LiczCols As Long

Dim bk As Workbook
Dim sh As Worksheet
Dim sh1 As Integer
Dim rng as Range

If Not Me.Saved Then
Msg = "Czy zapisac zmiany w (save the change in)"
Msg = Msg & Me.Name & "?"
ans = MsgBox(Msg, vbQuestion + vbYesNoCancel)
Select Case ans
Case vbYes
Me.Save
Case vbNo
Me.Saved = True
Case vbCancel
Cancel = True
Exit Sub
End Select
End If
Call DeleteMenu

' blokada komorek wpisanych t(he blockade of full cells )

sh1 = ActiveWorkbook.Worksheets.Count

Application.ScreenUpdating = False

For j = 1 To sh1

Sheets(j).Activate
Sheets(j).Unprotect
cells.Locked = True
set rng = nothing
On error resume Next
set rng = cells.SpecialCells(xlBlanks)
On Error goto 0
if not rng is nothing then
rng.Locked = False
end if
Sheets(j).Protect

Next j

Application.ScreenUpdating = True
End Sub

--
Regards,
Tom Ogilvy

"Andrzej" wrote in message
...
ok, but something is wrong.. because when find "cecha" displays
error: Aplication defined or object defined error.. (1004)

Mayby I made any mistakein filekatalog.xls?

Can you look at this code? (in file katalog)

Private Sub Workbook_BeforeClose(Cancel As Boolean)
Dim i, j, max, LiczCols As Integer

Dim bk As Workbook
Dim sh As Worksheet
Dim sh1 As Integer


If Not Me.Saved Then
Msg = "Czy zapisac zmiany w (save the change in)"
Msg = Msg & Me.Name & "?"
ans = MsgBox(Msg, vbQuestion + vbYesNoCancel)
Select Case ans
Case vbYes
Me.Save
Case vbNo
Me.Saved = True
Case vbCancel
Cancel = True
Exit Sub
End Select
End If
Call DeleteMenu

' blokada komorek wpisanych t(he blockade of full cells )

sh1 = ActiveWorkbook.Worksheets.Count

Application.ScreenUpdating = False

For j = 1 To sh1

Sheets(j).Activate
Sheets(j).Unprotect
'max = Range(Cells(1, 1), Selection.End _
(xlToRight)).Count
max = 1
'liczba kolumn wypełnionych
Cells(1, 1).Select
' okreslenie zakresu
LiczCols = Range(Selection, Selection.End _
(xlToRight)).Count
For i = 1 To LiczCols
If Range(Selection, Selection.End _
(xlDown)).Count max _
Then max = Range _
(Selection, Selection.End(xlDown)).Count
Cells(1, i).Select ' -in this line is ERROR
Next i
' Cells(10, 1) = "A1:A" & max
' zaznacz zakres i zablokuj niepuste komorki
Range("A1:A" & max).Select
Range(Selection, Selection.End _
(xlToRight)).Select
'Selection.Locked = True
For Each cell In Selection
If cell < "" Then cell.Locked = True
If cell = "" Then cell.Locked = False

Next cell

Sheets(j).Protect

Next j

Application.ScreenUpdating = True
End Sub





Użytkownik "Tom Ogilvy" napisał w wiadomości
...
On Error Resume Next
set bk = Workbooks("katalog.xls")
On Error goto 0
if bk is nothing then
Set bk = Workbooks.Open _

("D:\!Proj_temp_WSK\OPRZYRZADOWANIEv_6\NARZEDZIA\B AZA\katalog.xls")
End if

--
Regards,
Tom Ogilvy




"Andrzej" wrote in message
...
I have a code:

Private Sub Worksheet_Change(ByVal Target As Range)
Dim szukana As Range
Dim Cecha As String
Dim bk As Workbook
Dim sh As Worksheet
Dim sh1 As Worksheet

Application.ScreenUpdating = False

If Not Application.Intersect(Columns("A:A"), Target) _
Is Nothing Then

Cecha = Target.Value
If Cecha = "" Then Exit Sub

On Error Resume Next
Set bk = Workbooks _

("D:\!Proj_temp_WSK\OPRZYRZADOWANIEv_6\NARZEDZIA\B AZA\katalog.xls")
On Error GoTo 0
If bk Is Nothing Then
If Err < 0 Then
Set bk = Workbooks.Open _






(Filename:="D:\!Proj_temp_WSK\OPRZYRZADOWANIEv_6\N ARZEDZIA\BAZA\katalog.xls"
)

End If

Set sh1 = bk.Worksheets(bk.Worksheets.Count)
For Each sh In bk.Worksheets
Set szukana = sh.Cells.Find(What:=Cecha, _
After:=ActiveCell, LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByColumns, _
SearchDirection:=xlNext, MatchCase:=False)
', _
' SearchFormat:=False)

If szukana Is Nothing Then
If sh.Name = sh1.Name Then
MsgBox "Szukana cecha """ & Cecha & """ nie została
odnaleziona"
ActiveWorkbook.Close
Target.Value = ""
End If
Else

bk.Activate
sh.Activate
szukana.Activate
MsgBox "Szukana cecha """ & Cecha & """ została
odnaleziona"
'ActiveWorkbook.Close
'ActiveCell.Value = Cecha
End If
Next sh

End If

Application.ScreenUpdating = True

end sub

I try to ptecect my code before situation that file:

("D:\!Proj_temp_WSK\OPRZYRZADOWANIEv_6\NARZEDZIA\B AZA\katalog.xls")
was earlier opened by differend user.
If this file was earlier opened, then I would like to my code
don't
open
again this file, just only search for "cecha"
else
i would like to my code open the file and search for "cecha"

Someone knows more practical solution ?
this my does not work

Andrzej

Tom Ogilvy
On error resume next? question - problem
 
I can look at the protect unprotect if you want to send it to



--
Regards,
Tom Ogilvy


"Andrzej" wrote in message
...
Hi, Tom

I do not know why... but cells be blocked variously ( I would say that
accidentally). Sometimes every sheet, sometimes only one column...
Surely will you give this strange ? but it yes.

maybe therefore, that in my project are more options... and something
"bites" maybe? For example: the adding for administrator of file the new
menu (and his removal after close)

I think that only solution to this work correctly (because it can we do
not
understand each other) it is.. if you saw this project on live.

I do not know I should ask about this? but I will ask..

Could I send my project on your priv??

Pozdrawiam,

Andrzej



Użytkownik "Tom Ogilvy" napisał w wiadomości
...
That is what the code does (based on the assumptions I stated). Sorry
if
you can't get it to work for you.

--
Regards,
Tom Ogilvy


"Andrzej" wrote in message
...
your code didn' t work corectly..

I need:

If cells are empty then is unlock
and if cells.value <"" then i wont to lock this cells in every
sheets..



Użytkownik "Tom Ogilvy" napisał w wiadomości
...
If by

If cell = "" Then cell.Locked = False

you want to unlock empty cells then


Private Sub Workbook_BeforeClose(Cancel As Boolean)
Dim i as long, j as Long, max as Long
Dim LiczCols As Long

Dim bk As Workbook
Dim sh As Worksheet
Dim sh1 As Integer
Dim rng as Range

If Not Me.Saved Then
Msg = "Czy zapisac zmiany w (save the change in)"
Msg = Msg & Me.Name & "?"
ans = MsgBox(Msg, vbQuestion + vbYesNoCancel)
Select Case ans
Case vbYes
Me.Save
Case vbNo
Me.Saved = True
Case vbCancel
Cancel = True
Exit Sub
End Select
End If
Call DeleteMenu

' blokada komorek wpisanych t(he blockade of full cells )

sh1 = ActiveWorkbook.Worksheets.Count

Application.ScreenUpdating = False

For j = 1 To sh1

Sheets(j).Activate
Sheets(j).Unprotect
cells.Locked = True
set rng = nothing
On error resume Next
set rng = cells.SpecialCells(xlBlanks)
On Error goto 0
if not rng is nothing then
rng.Locked = False
end if
Sheets(j).Protect

Next j

Application.ScreenUpdating = True
End Sub

--
Regards,
Tom Ogilvy

"Andrzej" wrote in message
...
ok, but something is wrong.. because when find "cecha" displays
error: Aplication defined or object defined error.. (1004)

Mayby I made any mistakein filekatalog.xls?

Can you look at this code? (in file katalog)

Private Sub Workbook_BeforeClose(Cancel As Boolean)
Dim i, j, max, LiczCols As Integer

Dim bk As Workbook
Dim sh As Worksheet
Dim sh1 As Integer


If Not Me.Saved Then
Msg = "Czy zapisac zmiany w (save the change in)"
Msg = Msg & Me.Name & "?"
ans = MsgBox(Msg, vbQuestion + vbYesNoCancel)
Select Case ans
Case vbYes
Me.Save
Case vbNo
Me.Saved = True
Case vbCancel
Cancel = True
Exit Sub
End Select
End If
Call DeleteMenu

' blokada komorek wpisanych t(he blockade of full cells )

sh1 = ActiveWorkbook.Worksheets.Count

Application.ScreenUpdating = False

For j = 1 To sh1

Sheets(j).Activate
Sheets(j).Unprotect
'max = Range(Cells(1, 1), Selection.End _
(xlToRight)).Count
max = 1
'liczba kolumn wypełnionych
Cells(1, 1).Select
' okreslenie zakresu
LiczCols = Range(Selection, Selection.End _
(xlToRight)).Count
For i = 1 To LiczCols
If Range(Selection, Selection.End _
(xlDown)).Count max _
Then max = Range _
(Selection, Selection.End(xlDown)).Count
Cells(1, i).Select ' -in this line is ERROR
Next i
' Cells(10, 1) = "A1:A" & max
' zaznacz zakres i zablokuj niepuste komorki
Range("A1:A" & max).Select
Range(Selection, Selection.End _
(xlToRight)).Select
'Selection.Locked = True
For Each cell In Selection
If cell < "" Then cell.Locked = True
If cell = "" Then cell.Locked = False

Next cell

Sheets(j).Protect

Next j

Application.ScreenUpdating = True
End Sub





Użytkownik "Tom Ogilvy" napisał w wiadomości
...
On Error Resume Next
set bk = Workbooks("katalog.xls")
On Error goto 0
if bk is nothing then
Set bk = Workbooks.Open _

("D:\!Proj_temp_WSK\OPRZYRZADOWANIEv_6\NARZEDZIA\B AZA\katalog.xls")
End if

--
Regards,
Tom Ogilvy




"Andrzej" wrote in message
...
I have a code:

Private Sub Worksheet_Change(ByVal Target As Range)
Dim szukana As Range
Dim Cecha As String
Dim bk As Workbook
Dim sh As Worksheet
Dim sh1 As Worksheet

Application.ScreenUpdating = False

If Not Application.Intersect(Columns("A:A"), Target) _
Is Nothing Then

Cecha = Target.Value
If Cecha = "" Then Exit Sub

On Error Resume Next
Set bk = Workbooks _

("D:\!Proj_temp_WSK\OPRZYRZADOWANIEv_6\NARZEDZIA\B AZA\katalog.xls")
On Error GoTo 0
If bk Is Nothing Then
If Err < 0 Then
Set bk = Workbooks.Open _







(Filename:="D:\!Proj_temp_WSK\OPRZYRZADOWANIEv_6\N ARZEDZIA\BAZA\katalog.xls"
)

End If

Set sh1 = bk.Worksheets(bk.Worksheets.Count)
For Each sh In bk.Worksheets
Set szukana = sh.Cells.Find(What:=Cecha, _
After:=ActiveCell, LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByColumns, _
SearchDirection:=xlNext, MatchCase:=False)
', _
' SearchFormat:=False)

If szukana Is Nothing Then
If sh.Name = sh1.Name Then
MsgBox "Szukana cecha """ & Cecha & """ nie została
odnaleziona"
ActiveWorkbook.Close
Target.Value = ""
End If
Else

bk.Activate
sh.Activate
szukana.Activate
MsgBox "Szukana cecha """ & Cecha & """ została
odnaleziona"
'ActiveWorkbook.Close
'ActiveCell.Value = Cecha
End If
Next sh

End If

Application.ScreenUpdating = True

end sub

I try to ptecect my code before situation that file:

("D:\!Proj_temp_WSK\OPRZYRZADOWANIEv_6\NARZEDZIA\B AZA\katalog.xls")
was earlier opened by differend user.
If this file was earlier opened, then I would like to my
code
don't
open
again this file, just only search for "cecha"
else
i would like to my code open the file and search for "cecha"

Someone knows more practical solution ?
this my does not work

Andrzej

Andrzej
On error resume next? question - problem
 
Hi Tom,
I know probably?? why we don't understand each other.
Your code selected some range (similarly how this was in my code) for
example A1:D20 it agrees?
and in this range it work correctly. If cells empty - unlock it,
if cell is full lock it.. OK, but all cells below this range are LOCK,
and I would like to they were UNLOCK., because users will be write new data
(records),, but how will they write if cells be blocked?

in this example I would like to:

1) column Tand every follows will be lock (U,V,W etc)

2) in range A1:D20 (if cell full - lock, if cell empty - unlock)

3) every cells belows row 20 (but only to column number 20) will be unlock
(A21:T65535)

I hope so you understand me.



Pozdrawiam Andrzej








Użytkownik "Tom Ogilvy" napisał w wiadomości
...
That is what the code does (based on the assumptions I stated). Sorry if
you can't get it to work for you.

--
Regards,
Tom Ogilvy


"Andrzej" wrote in message
...
your code didn' t work corectly..

I need:

If cells are empty then is unlock
and if cells.value <"" then i wont to lock this cells in every
sheets..



Użytkownik "Tom Ogilvy" napisał w wiadomości
...
If by

If cell = "" Then cell.Locked = False

you want to unlock empty cells then


Private Sub Workbook_BeforeClose(Cancel As Boolean)
Dim i as long, j as Long, max as Long
Dim LiczCols As Long

Dim bk As Workbook
Dim sh As Worksheet
Dim sh1 As Integer
Dim rng as Range

If Not Me.Saved Then
Msg = "Czy zapisac zmiany w (save the change in)"
Msg = Msg & Me.Name & "?"
ans = MsgBox(Msg, vbQuestion + vbYesNoCancel)
Select Case ans
Case vbYes
Me.Save
Case vbNo
Me.Saved = True
Case vbCancel
Cancel = True
Exit Sub
End Select
End If
Call DeleteMenu

' blokada komorek wpisanych t(he blockade of full cells )

sh1 = ActiveWorkbook.Worksheets.Count

Application.ScreenUpdating = False

For j = 1 To sh1

Sheets(j).Activate
Sheets(j).Unprotect
cells.Locked = True
set rng = nothing
On error resume Next
set rng = cells.SpecialCells(xlBlanks)
On Error goto 0
if not rng is nothing then
rng.Locked = False
end if
Sheets(j).Protect

Next j

Application.ScreenUpdating = True
End Sub

--
Regards,
Tom Ogilvy

"Andrzej" wrote in message
...
ok, but something is wrong.. because when find "cecha" displays
error: Aplication defined or object defined error.. (1004)

Mayby I made any mistakein filekatalog.xls?

Can you look at this code? (in file katalog)

Private Sub Workbook_BeforeClose(Cancel As Boolean)
Dim i, j, max, LiczCols As Integer

Dim bk As Workbook
Dim sh As Worksheet
Dim sh1 As Integer


If Not Me.Saved Then
Msg = "Czy zapisac zmiany w (save the change in)"
Msg = Msg & Me.Name & "?"
ans = MsgBox(Msg, vbQuestion + vbYesNoCancel)
Select Case ans
Case vbYes
Me.Save
Case vbNo
Me.Saved = True
Case vbCancel
Cancel = True
Exit Sub
End Select
End If
Call DeleteMenu

' blokada komorek wpisanych t(he blockade of full cells )

sh1 = ActiveWorkbook.Worksheets.Count

Application.ScreenUpdating = False

For j = 1 To sh1

Sheets(j).Activate
Sheets(j).Unprotect
'max = Range(Cells(1, 1), Selection.End _
(xlToRight)).Count
max = 1
'liczba kolumn wypełnionych
Cells(1, 1).Select
' okreslenie zakresu
LiczCols = Range(Selection, Selection.End _
(xlToRight)).Count
For i = 1 To LiczCols
If Range(Selection, Selection.End _
(xlDown)).Count max _
Then max = Range _
(Selection, Selection.End(xlDown)).Count
Cells(1, i).Select ' -in this line is ERROR
Next i
' Cells(10, 1) = "A1:A" & max
' zaznacz zakres i zablokuj niepuste komorki
Range("A1:A" & max).Select
Range(Selection, Selection.End _
(xlToRight)).Select
'Selection.Locked = True
For Each cell In Selection
If cell < "" Then cell.Locked = True
If cell = "" Then cell.Locked = False

Next cell

Sheets(j).Protect

Next j

Application.ScreenUpdating = True
End Sub





Użytkownik "Tom Ogilvy" napisał w wiadomości
...
On Error Resume Next
set bk = Workbooks("katalog.xls")
On Error goto 0
if bk is nothing then
Set bk = Workbooks.Open _

("D:\!Proj_temp_WSK\OPRZYRZADOWANIEv_6\NARZEDZIA\B AZA\katalog.xls")
End if

--
Regards,
Tom Ogilvy




"Andrzej" wrote in message
...
I have a code:

Private Sub Worksheet_Change(ByVal Target As Range)
Dim szukana As Range
Dim Cecha As String
Dim bk As Workbook
Dim sh As Worksheet
Dim sh1 As Worksheet

Application.ScreenUpdating = False

If Not Application.Intersect(Columns("A:A"), Target) _
Is Nothing Then

Cecha = Target.Value
If Cecha = "" Then Exit Sub

On Error Resume Next
Set bk = Workbooks _

("D:\!Proj_temp_WSK\OPRZYRZADOWANIEv_6\NARZEDZIA\B AZA\katalog.xls")
On Error GoTo 0
If bk Is Nothing Then
If Err < 0 Then
Set bk = Workbooks.Open _






(Filename:="D:\!Proj_temp_WSK\OPRZYRZADOWANIEv_6\N ARZEDZIA\BAZA\katalog.xls"
)

End If

Set sh1 = bk.Worksheets(bk.Worksheets.Count)
For Each sh In bk.Worksheets
Set szukana = sh.Cells.Find(What:=Cecha, _
After:=ActiveCell, LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByColumns, _
SearchDirection:=xlNext, MatchCase:=False)
', _
' SearchFormat:=False)

If szukana Is Nothing Then
If sh.Name = sh1.Name Then
MsgBox "Szukana cecha """ & Cecha & """ nie została
odnaleziona"
ActiveWorkbook.Close
Target.Value = ""
End If
Else

bk.Activate
sh.Activate
szukana.Activate
MsgBox "Szukana cecha """ & Cecha & """ została
odnaleziona"
'ActiveWorkbook.Close
'ActiveCell.Value = Cecha
End If
Next sh

End If

Application.ScreenUpdating = True

end sub

I try to ptecect my code before situation that file:

("D:\!Proj_temp_WSK\OPRZYRZADOWANIEv_6\NARZEDZIA\B AZA\katalog.xls")
was earlier opened by differend user.
If this file was earlier opened, then I would like to my code
don't
open
again this file, just only search for "cecha"
else
i would like to my code open the file and search for "cecha"

Someone knows more practical solution ?
this my does not work

Andrzej

Tom Ogilvy
On error resume next? question - problem
 
Just make unlock the default

Dim rng1 as Range
Dim rng2 as Range
Cells.Locked = False
on Error Resume Next
set rng1 = cells.SpecialCells(xlconstants)
set rng2 = cells.specialCells(xlformulas)
On Error goto 0
if not rng1 is nothing then rng1.Locked = True
if not rng2 is nothing then rng2.Locked = True

--
Regards,
Tom Ogilvy

"Andrzej" wrote in message
...
Hi Tom,
I know probably?? why we don't understand each other.
Your code selected some range (similarly how this was in my code) for
example A1:D20 it agrees?
and in this range it work correctly. If cells empty - unlock it,
if cell is full lock it.. OK, but all cells below this range are LOCK,
and I would like to they were UNLOCK., because users will be write new
data
(records),, but how will they write if cells be blocked?

in this example I would like to:

1) column Tand every follows will be lock (U,V,W etc)

2) in range A1:D20 (if cell full - lock, if cell empty - unlock)

3) every cells belows row 20 (but only to column number 20) will be unlock
(A21:T65535)

I hope so you understand me.



Pozdrawiam Andrzej








Użytkownik "Tom Ogilvy" napisał w wiadomości
...
That is what the code does (based on the assumptions I stated). Sorry
if
you can't get it to work for you.

--
Regards,
Tom Ogilvy


"Andrzej" wrote in message
...
your code didn' t work corectly..

I need:

If cells are empty then is unlock
and if cells.value <"" then i wont to lock this cells in every
sheets..



Użytkownik "Tom Ogilvy" napisał w wiadomości
...
If by

If cell = "" Then cell.Locked = False

you want to unlock empty cells then


Private Sub Workbook_BeforeClose(Cancel As Boolean)
Dim i as long, j as Long, max as Long
Dim LiczCols As Long

Dim bk As Workbook
Dim sh As Worksheet
Dim sh1 As Integer
Dim rng as Range

If Not Me.Saved Then
Msg = "Czy zapisac zmiany w (save the change in)"
Msg = Msg & Me.Name & "?"
ans = MsgBox(Msg, vbQuestion + vbYesNoCancel)
Select Case ans
Case vbYes
Me.Save
Case vbNo
Me.Saved = True
Case vbCancel
Cancel = True
Exit Sub
End Select
End If
Call DeleteMenu

' blokada komorek wpisanych t(he blockade of full cells )

sh1 = ActiveWorkbook.Worksheets.Count

Application.ScreenUpdating = False

For j = 1 To sh1

Sheets(j).Activate
Sheets(j).Unprotect
cells.Locked = True
set rng = nothing
On error resume Next
set rng = cells.SpecialCells(xlBlanks)
On Error goto 0
if not rng is nothing then
rng.Locked = False
end if
Sheets(j).Protect

Next j

Application.ScreenUpdating = True
End Sub

--
Regards,
Tom Ogilvy

"Andrzej" wrote in message
...
ok, but something is wrong.. because when find "cecha" displays
error: Aplication defined or object defined error.. (1004)

Mayby I made any mistakein filekatalog.xls?

Can you look at this code? (in file katalog)

Private Sub Workbook_BeforeClose(Cancel As Boolean)
Dim i, j, max, LiczCols As Integer

Dim bk As Workbook
Dim sh As Worksheet
Dim sh1 As Integer


If Not Me.Saved Then
Msg = "Czy zapisac zmiany w (save the change in)"
Msg = Msg & Me.Name & "?"
ans = MsgBox(Msg, vbQuestion + vbYesNoCancel)
Select Case ans
Case vbYes
Me.Save
Case vbNo
Me.Saved = True
Case vbCancel
Cancel = True
Exit Sub
End Select
End If
Call DeleteMenu

' blokada komorek wpisanych t(he blockade of full cells )

sh1 = ActiveWorkbook.Worksheets.Count

Application.ScreenUpdating = False

For j = 1 To sh1

Sheets(j).Activate
Sheets(j).Unprotect
'max = Range(Cells(1, 1), Selection.End _
(xlToRight)).Count
max = 1
'liczba kolumn wypełnionych
Cells(1, 1).Select
' okreslenie zakresu
LiczCols = Range(Selection, Selection.End _
(xlToRight)).Count
For i = 1 To LiczCols
If Range(Selection, Selection.End _
(xlDown)).Count max _
Then max = Range _
(Selection, Selection.End(xlDown)).Count
Cells(1, i).Select ' -in this line is ERROR
Next i
' Cells(10, 1) = "A1:A" & max
' zaznacz zakres i zablokuj niepuste komorki
Range("A1:A" & max).Select
Range(Selection, Selection.End _
(xlToRight)).Select
'Selection.Locked = True
For Each cell In Selection
If cell < "" Then cell.Locked = True
If cell = "" Then cell.Locked = False

Next cell

Sheets(j).Protect

Next j

Application.ScreenUpdating = True
End Sub





Użytkownik "Tom Ogilvy" napisał w wiadomości
...
On Error Resume Next
set bk = Workbooks("katalog.xls")
On Error goto 0
if bk is nothing then
Set bk = Workbooks.Open _

("D:\!Proj_temp_WSK\OPRZYRZADOWANIEv_6\NARZEDZIA\B AZA\katalog.xls")
End if

--
Regards,
Tom Ogilvy




"Andrzej" wrote in message
...
I have a code:

Private Sub Worksheet_Change(ByVal Target As Range)
Dim szukana As Range
Dim Cecha As String
Dim bk As Workbook
Dim sh As Worksheet
Dim sh1 As Worksheet

Application.ScreenUpdating = False

If Not Application.Intersect(Columns("A:A"), Target) _
Is Nothing Then

Cecha = Target.Value
If Cecha = "" Then Exit Sub

On Error Resume Next
Set bk = Workbooks _

("D:\!Proj_temp_WSK\OPRZYRZADOWANIEv_6\NARZEDZIA\B AZA\katalog.xls")
On Error GoTo 0
If bk Is Nothing Then
If Err < 0 Then
Set bk = Workbooks.Open _







(Filename:="D:\!Proj_temp_WSK\OPRZYRZADOWANIEv_6\N ARZEDZIA\BAZA\katalog.xls"
)

End If

Set sh1 = bk.Worksheets(bk.Worksheets.Count)
For Each sh In bk.Worksheets
Set szukana = sh.Cells.Find(What:=Cecha, _
After:=ActiveCell, LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByColumns, _
SearchDirection:=xlNext, MatchCase:=False)
', _
' SearchFormat:=False)

If szukana Is Nothing Then
If sh.Name = sh1.Name Then
MsgBox "Szukana cecha """ & Cecha & """ nie została
odnaleziona"
ActiveWorkbook.Close
Target.Value = ""
End If
Else

bk.Activate
sh.Activate
szukana.Activate
MsgBox "Szukana cecha """ & Cecha & """ została
odnaleziona"
'ActiveWorkbook.Close
'ActiveCell.Value = Cecha
End If
Next sh

End If

Application.ScreenUpdating = True

end sub

I try to ptecect my code before situation that file:

("D:\!Proj_temp_WSK\OPRZYRZADOWANIEv_6\NARZEDZIA\B AZA\katalog.xls")
was earlier opened by differend user.
If this file was earlier opened, then I would like to my
code
don't
open
again this file, just only search for "cecha"
else
i would like to my code open the file and search for "cecha"

Someone knows more practical solution ?
this my does not work

Andrzej

Andrzej
On error resume next? question - problem
 
OK
this code work for every cells for sheets.. but I would like to every cells
(colums) on the right of last this cells
Cecha RSAb Sekcja/Osoba/Data

will be lock.

If you open my project.. so probably you will be know what I want.

Pozdrowienia
Andrzej

Użytkownik "Tom Ogilvy" napisał w wiadomości
...
Just make unlock the default

Dim rng1 as Range
Dim rng2 as Range
Cells.Locked = False
on Error Resume Next
set rng1 = cells.SpecialCells(xlconstants)
set rng2 = cells.specialCells(xlformulas)
On Error goto 0
if not rng1 is nothing then rng1.Locked = True
if not rng2 is nothing then rng2.Locked = True

--
Regards,
Tom Ogilvy

"Andrzej" wrote in message
...
Hi Tom,
I know probably?? why we don't understand each other.
Your code selected some range (similarly how this was in my code) for
example A1:D20 it agrees?
and in this range it work correctly. If cells empty - unlock it,
if cell is full lock it.. OK, but all cells below this range are LOCK,
and I would like to they were UNLOCK., because users will be write new
data
(records),, but how will they write if cells be blocked?

in this example I would like to:

1) column Tand every follows will be lock (U,V,W etc)

2) in range A1:D20 (if cell full - lock, if cell empty - unlock)

3) every cells belows row 20 (but only to column number 20) will be
unlock
(A21:T65535)

I hope so you understand me.



Pozdrawiam Andrzej








Użytkownik "Tom Ogilvy" napisał w wiadomości
...
That is what the code does (based on the assumptions I stated). Sorry
if
you can't get it to work for you.

--
Regards,
Tom Ogilvy


"Andrzej" wrote in message
...
your code didn' t work corectly..

I need:

If cells are empty then is unlock
and if cells.value <"" then i wont to lock this cells in every
sheets..



Użytkownik "Tom Ogilvy" napisał w wiadomości
...
If by

If cell = "" Then cell.Locked = False

you want to unlock empty cells then


Private Sub Workbook_BeforeClose(Cancel As Boolean)
Dim i as long, j as Long, max as Long
Dim LiczCols As Long

Dim bk As Workbook
Dim sh As Worksheet
Dim sh1 As Integer
Dim rng as Range

If Not Me.Saved Then
Msg = "Czy zapisac zmiany w (save the change in)"
Msg = Msg & Me.Name & "?"
ans = MsgBox(Msg, vbQuestion + vbYesNoCancel)
Select Case ans
Case vbYes
Me.Save
Case vbNo
Me.Saved = True
Case vbCancel
Cancel = True
Exit Sub
End Select
End If
Call DeleteMenu

' blokada komorek wpisanych t(he blockade of full cells )

sh1 = ActiveWorkbook.Worksheets.Count

Application.ScreenUpdating = False

For j = 1 To sh1

Sheets(j).Activate
Sheets(j).Unprotect
cells.Locked = True
set rng = nothing
On error resume Next
set rng = cells.SpecialCells(xlBlanks)
On Error goto 0
if not rng is nothing then
rng.Locked = False
end if
Sheets(j).Protect

Next j

Application.ScreenUpdating = True
End Sub

--
Regards,
Tom Ogilvy

"Andrzej" wrote in message
...
ok, but something is wrong.. because when find "cecha" displays
error: Aplication defined or object defined error.. (1004)

Mayby I made any mistakein filekatalog.xls?

Can you look at this code? (in file katalog)

Private Sub Workbook_BeforeClose(Cancel As Boolean)
Dim i, j, max, LiczCols As Integer

Dim bk As Workbook
Dim sh As Worksheet
Dim sh1 As Integer


If Not Me.Saved Then
Msg = "Czy zapisac zmiany w (save the change in)"
Msg = Msg & Me.Name & "?"
ans = MsgBox(Msg, vbQuestion + vbYesNoCancel)
Select Case ans
Case vbYes
Me.Save
Case vbNo
Me.Saved = True
Case vbCancel
Cancel = True
Exit Sub
End Select
End If
Call DeleteMenu

' blokada komorek wpisanych t(he blockade of full cells )

sh1 = ActiveWorkbook.Worksheets.Count

Application.ScreenUpdating = False

For j = 1 To sh1

Sheets(j).Activate
Sheets(j).Unprotect
'max = Range(Cells(1, 1), Selection.End _
(xlToRight)).Count
max = 1
'liczba kolumn wypełnionych
Cells(1, 1).Select
' okreslenie zakresu
LiczCols = Range(Selection, Selection.End _
(xlToRight)).Count
For i = 1 To LiczCols
If Range(Selection, Selection.End _
(xlDown)).Count max _
Then max = Range _
(Selection, Selection.End(xlDown)).Count
Cells(1, i).Select ' -in this line is
ERROR
Next i
' Cells(10, 1) = "A1:A" & max
' zaznacz zakres i zablokuj niepuste komorki
Range("A1:A" & max).Select
Range(Selection, Selection.End _
(xlToRight)).Select
'Selection.Locked = True
For Each cell In Selection
If cell < "" Then cell.Locked = True
If cell = "" Then cell.Locked = False

Next cell

Sheets(j).Protect

Next j

Application.ScreenUpdating = True
End Sub





Użytkownik "Tom Ogilvy" napisał w wiadomości
...
On Error Resume Next
set bk = Workbooks("katalog.xls")
On Error goto 0
if bk is nothing then
Set bk = Workbooks.Open _


("D:\!Proj_temp_WSK\OPRZYRZADOWANIEv_6\NARZEDZIA\B AZA\katalog.xls")
End if

--
Regards,
Tom Ogilvy




"Andrzej" wrote in message
...
I have a code:

Private Sub Worksheet_Change(ByVal Target As Range)
Dim szukana As Range
Dim Cecha As String
Dim bk As Workbook
Dim sh As Worksheet
Dim sh1 As Worksheet

Application.ScreenUpdating = False

If Not Application.Intersect(Columns("A:A"), Target) _
Is Nothing Then

Cecha = Target.Value
If Cecha = "" Then Exit Sub

On Error Resume Next
Set bk = Workbooks _

("D:\!Proj_temp_WSK\OPRZYRZADOWANIEv_6\NARZEDZIA\B AZA\katalog.xls")
On Error GoTo 0
If bk Is Nothing Then
If Err < 0 Then
Set bk = Workbooks.Open _








(Filename:="D:\!Proj_temp_WSK\OPRZYRZADOWANIEv_6\N ARZEDZIA\BAZA\katalog.xls"
)

End If

Set sh1 = bk.Worksheets(bk.Worksheets.Count)
For Each sh In bk.Worksheets
Set szukana = sh.Cells.Find(What:=Cecha, _
After:=ActiveCell, LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByColumns, _
SearchDirection:=xlNext, MatchCase:=False)
', _
' SearchFormat:=False)

If szukana Is Nothing Then
If sh.Name = sh1.Name Then
MsgBox "Szukana cecha """ & Cecha & """ nie została
odnaleziona"
ActiveWorkbook.Close
Target.Value = ""
End If
Else

bk.Activate
sh.Activate
szukana.Activate
MsgBox "Szukana cecha """ & Cecha & """ została
odnaleziona"
'ActiveWorkbook.Close
'ActiveCell.Value = Cecha
End If
Next sh

End If

Application.ScreenUpdating = True

end sub

I try to ptecect my code before situation that file:

("D:\!Proj_temp_WSK\OPRZYRZADOWANIEv_6\NARZEDZIA\B AZA\katalog.xls")
was earlier opened by differend user.
If this file was earlier opened, then I would like to my
code
don't
open
again this file, just only search for "cecha"
else
i would like to my code open the file and search for "cecha"

Someone knows more practical solution ?
this my does not work

Andrzej

Tom Ogilvy
On error resume next? question - problem
 
Dim rng1 as Range
Dim rng2 as Range
Cells.Locked = False
on Error Resume Next
set rng1 = cells.SpecialCells(xlconstants)
set rng2 = cells.specialCells(xlformulas)
On Error goto 0
if not rng1 is nothing then rng1.Locked = True
if not rng2 is nothing then rng2.Locked = True
Range("A:IV").Locked = True


Adjust to suit.

--
Regards,
Tom Ogilvy

"Andrzej" wrote in message
...
OK
this code work for every cells for sheets.. but I would like to every
cells
(colums) on the right of last this cells
Cecha RSAb Sekcja/Osoba/Data

will be lock.

If you open my project.. so probably you will be know what I want.

Pozdrowienia
Andrzej

Użytkownik "Tom Ogilvy" napisał w wiadomości
...
Just make unlock the default

Dim rng1 as Range
Dim rng2 as Range
Cells.Locked = False
on Error Resume Next
set rng1 = cells.SpecialCells(xlconstants)
set rng2 = cells.specialCells(xlformulas)
On Error goto 0
if not rng1 is nothing then rng1.Locked = True
if not rng2 is nothing then rng2.Locked = True

--
Regards,
Tom Ogilvy

"Andrzej" wrote in message
...
Hi Tom,
I know probably?? why we don't understand each other.
Your code selected some range (similarly how this was in my code) for
example A1:D20 it agrees?
and in this range it work correctly. If cells empty - unlock it,
if cell is full lock it.. OK, but all cells below this range are LOCK,
and I would like to they were UNLOCK., because users will be write new
data
(records),, but how will they write if cells be blocked?

in this example I would like to:

1) column Tand every follows will be lock (U,V,W etc)

2) in range A1:D20 (if cell full - lock, if cell empty - unlock)

3) every cells belows row 20 (but only to column number 20) will be
unlock
(A21:T65535)

I hope so you understand me.



Pozdrawiam Andrzej








Użytkownik "Tom Ogilvy" napisał w wiadomości
...
That is what the code does (based on the assumptions I stated).
Sorry
if
you can't get it to work for you.

--
Regards,
Tom Ogilvy


"Andrzej" wrote in message
...
your code didn' t work corectly..

I need:

If cells are empty then is unlock
and if cells.value <"" then i wont to lock this cells in every
sheets..



Użytkownik "Tom Ogilvy" napisał w wiadomości
...
If by

If cell = "" Then cell.Locked = False

you want to unlock empty cells then


Private Sub Workbook_BeforeClose(Cancel As Boolean)
Dim i as long, j as Long, max as Long
Dim LiczCols As Long

Dim bk As Workbook
Dim sh As Worksheet
Dim sh1 As Integer
Dim rng as Range

If Not Me.Saved Then
Msg = "Czy zapisac zmiany w (save the change in)"
Msg = Msg & Me.Name & "?"
ans = MsgBox(Msg, vbQuestion + vbYesNoCancel)
Select Case ans
Case vbYes
Me.Save
Case vbNo
Me.Saved = True
Case vbCancel
Cancel = True
Exit Sub
End Select
End If
Call DeleteMenu

' blokada komorek wpisanych t(he blockade of full cells )

sh1 = ActiveWorkbook.Worksheets.Count

Application.ScreenUpdating = False

For j = 1 To sh1

Sheets(j).Activate
Sheets(j).Unprotect
cells.Locked = True
set rng = nothing
On error resume Next
set rng = cells.SpecialCells(xlBlanks)
On Error goto 0
if not rng is nothing then
rng.Locked = False
end if
Sheets(j).Protect

Next j

Application.ScreenUpdating = True
End Sub

--
Regards,
Tom Ogilvy

"Andrzej" wrote in message
...
ok, but something is wrong.. because when find "cecha"
displays
error: Aplication defined or object defined error.. (1004)

Mayby I made any mistakein filekatalog.xls?

Can you look at this code? (in file katalog)

Private Sub Workbook_BeforeClose(Cancel As Boolean)
Dim i, j, max, LiczCols As Integer

Dim bk As Workbook
Dim sh As Worksheet
Dim sh1 As Integer


If Not Me.Saved Then
Msg = "Czy zapisac zmiany w (save the change in)"
Msg = Msg & Me.Name & "?"
ans = MsgBox(Msg, vbQuestion + vbYesNoCancel)
Select Case ans
Case vbYes
Me.Save
Case vbNo
Me.Saved = True
Case vbCancel
Cancel = True
Exit Sub
End Select
End If
Call DeleteMenu

' blokada komorek wpisanych t(he blockade of full cells )

sh1 = ActiveWorkbook.Worksheets.Count

Application.ScreenUpdating = False

For j = 1 To sh1

Sheets(j).Activate
Sheets(j).Unprotect
'max = Range(Cells(1, 1), Selection.End _
(xlToRight)).Count
max = 1
'liczba kolumn wypełnionych
Cells(1, 1).Select
' okreslenie zakresu
LiczCols = Range(Selection, Selection.End _
(xlToRight)).Count
For i = 1 To LiczCols
If Range(Selection, Selection.End _
(xlDown)).Count max _
Then max = Range _
(Selection, Selection.End(xlDown)).Count
Cells(1, i).Select ' -in this line is
ERROR
Next i
' Cells(10, 1) = "A1:A" & max
' zaznacz zakres i zablokuj niepuste komorki
Range("A1:A" & max).Select
Range(Selection, Selection.End _
(xlToRight)).Select
'Selection.Locked = True
For Each cell In Selection
If cell < "" Then cell.Locked = True
If cell = "" Then cell.Locked = False

Next cell

Sheets(j).Protect

Next j

Application.ScreenUpdating = True
End Sub





Użytkownik "Tom Ogilvy" napisał w
wiadomości
...
On Error Resume Next
set bk = Workbooks("katalog.xls")
On Error goto 0
if bk is nothing then
Set bk = Workbooks.Open _


("D:\!Proj_temp_WSK\OPRZYRZADOWANIEv_6\NARZEDZIA\B AZA\katalog.xls")
End if

--
Regards,
Tom Ogilvy




"Andrzej" wrote in message
...
I have a code:

Private Sub Worksheet_Change(ByVal Target As Range)
Dim szukana As Range
Dim Cecha As String
Dim bk As Workbook
Dim sh As Worksheet
Dim sh1 As Worksheet

Application.ScreenUpdating = False

If Not Application.Intersect(Columns("A:A"), Target) _
Is Nothing Then

Cecha = Target.Value
If Cecha = "" Then Exit Sub

On Error Resume Next
Set bk = Workbooks _

("D:\!Proj_temp_WSK\OPRZYRZADOWANIEv_6\NARZEDZIA\B AZA\katalog.xls")
On Error GoTo 0
If bk Is Nothing Then
If Err < 0 Then
Set bk = Workbooks.Open _









(Filename:="D:\!Proj_temp_WSK\OPRZYRZADOWANIEv_6\N ARZEDZIA\BAZA\katalog.xls"
)

End If

Set sh1 = bk.Worksheets(bk.Worksheets.Count)
For Each sh In bk.Worksheets
Set szukana = sh.Cells.Find(What:=Cecha, _
After:=ActiveCell, LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByColumns, _
SearchDirection:=xlNext, MatchCase:=False)
', _
' SearchFormat:=False)

If szukana Is Nothing Then
If sh.Name = sh1.Name Then
MsgBox "Szukana cecha """ & Cecha & """ nie została
odnaleziona"
ActiveWorkbook.Close
Target.Value = ""
End If
Else

bk.Activate
sh.Activate
szukana.Activate
MsgBox "Szukana cecha """ & Cecha & """ została
odnaleziona"
'ActiveWorkbook.Close
'ActiveCell.Value = Cecha
End If
Next sh

End If

Application.ScreenUpdating = True

end sub

I try to ptecect my code before situation that file:

("D:\!Proj_temp_WSK\OPRZYRZADOWANIEv_6\NARZEDZIA\B AZA\katalog.xls")
was earlier opened by differend user.
If this file was earlier opened, then I would like to my
code
don't
open
again this file, just only search for "cecha"
else
i would like to my code open the file and search for
"cecha"

Someone knows more practical solution ?
this my does not work

Andrzej


All times are GMT +1. The time now is 01:42 AM.

Powered by vBulletin® Copyright ©2000 - 2025, Jelsoft Enterprises Ltd.
ExcelBanter.com