add record to first free row in all sheets

[saban]

Ok I have managed to put records into all sheets with this code:
[VBA] Option Explicit
Dim st As Integer

Private Sub UserForm_Activate()
'Activamos la primera celda
'susceptible de contener datos
'Range("a65536").End(xlUp).Offset(1, 0).Activate
ActiveSheet.Range("a3").Activate
'Buscamos la primera fila sin
'datos en la columna nombre
Do While Not IsEmpty(ActiveCell)
ActiveCell.Offset(1, 0).Activate
Loop
End Sub
Private Sub cmdAceptar_Click()
'Antes de ingresar los datos
'comprobamos que sean correctos
ValidarCampos
End Sub
Private Sub cmdTerminar_Click()
'Descargamos el formulario
Unload frmTomarDatos
End Sub
Private Sub txtEntidad_Change()
'Al escribir los 4 d?gitos de la entidad
'pasamos al siguiente campo
If Len(txtEntidad.Text) = 4 Then
txtOficina.SetFocus
End If
End Sub
Private Sub txtOficina_Change()
'Al escribir los 4 d?gitos de la oficina
'pasamos al siguiente campo
If Len(txtOficina.Text) = 4 Then
txtControl.SetFocus
End If
End Sub
Private Sub txtControl_Change()
'Al escribir los 2 d?gitos de control
'pasamos al siguiente campo
If Len(txtControl.Text) = Date Then
txtCuenta.SetFocus
End If
End Sub
Private Sub txtCuenta_Change()
'Al escribir los 10 d?gitos del n?mero
'de cuenta situamos el foco sobre el
'bot?n cmdAceptar
If Len(txtCuenta.Text) = 10 Then
cmdAceptar.SetFocus
End If
End Sub
Private Sub ValidarCampos()

Dim r As Long
Dim c As Long
Dim i As Long
Dim Error As String
Dim ws As Worksheet
Dim ValorMensaje As Long

'Turn off Screen refresh
Application.ScreenUpdating = False

'Use Cells(Row, Column) for range adddress
r = ActiveCell.Row
c = ActiveCell.Column

For i = 1 To Sheets.Count
'Use ws as worksheet(sheet number)
Do While Not IsEmpty(ActiveCell)
ActiveCell.Offset(1, 0).Activate
Loop
Set ws = Worksheets(i)
'r = ws.Range("a65536").End(xlUp).Row

' ws.Range("A1").Value = frmTomarDatos.txtNombre.Value
Error = "napaka v datumu"
If Len(frmTomarDatos.txtNombre.Text) = 0 Then
ValorMensaje = MsgBox("El campo Nombre est? vac?o", vbOKOnly, Error)
frmTomarDatos.txtNombre.SetFocus
' Was error so exit sub to correct error
Exit Sub
Else
If Len(frmTomarDatos.txtApellidos.Text) = 0 Then
ValorMensaje = MsgBox("vnesi podatke", vbOKOnly, Error)
frmTomarDatos.txtApellidos.SetFocus
' Was error so exit sub to correct error
Exit Sub
Else
' st is used elewhere?
st = frmTomarDatos.txtNombre.Text * 1
With ws.Cells(r, c)
.Value = txtNombre * 1
.Offset(0, 1).Value = frmTomarDatos.txtApellidos.Value
.Offset(0, 2).Value = frmTomarDatos.txtEntidad.Value * 1
.Offset(0, 3).Value = frmTomarDatos.txtOficina.Value
.Offset(0, 4).Value = frmTomarDatos.txtControl.Value
.Offset(0, 5).Value = frmTomarDatos.txtCuenta.Value
End With
'**************************************************
'Don't know what this does!
' ActiveCell.Offset(1, 0).Activate
' BorrarFormulario
'**************************************************
End If
End If
Next i

'Turn Screen refresh on
Application.ScreenUpdating = True

End Sub

Private Sub UserForm_Initialize()

txtNombre.Value = Null
' txtNombre.Value = Null
txtApellidos.Value = Null
txtEntidad.Value = Null
txtOficina.Value = Null
txtControl.Value = Null
txtCuenta.Value = Null

End Sub

Private Sub BorrarFormulario()
'Ponemos la cadena vac?a
'a todos los campos
txtNombre.Text = ""
txtApellidos.Text = ""
txtEntidad.Text = ""
txtOficina.Text = ""
txtControl.Text = ""
txtCuenta.Text = ""
'Situamos el foco en el campo Nombre
txtNombre.SetFocus
End Sub
[/VBA]

But the problem is I would like to put records in free rows not to overwrite the existing ones
ex: in sheet1 I add record to free row(lets say in 6 row) it works fine but when I look into other sheets it adds data but it overwrites sixth row and i dont wanna do that I would like to put this data in free row (not in the same row as in sheet1).

And when this is done I would like to delete data added in sheets where cells in G column says "Zaseden" and is higlighted with red

thnx for any advice

[Rembo]

Hello saban,

.. the problem is I would like to put records in free rows not to overwrite the existing ones
ex: in sheet1 I add record to free row(lets say in 6 row) it works fine but when I look into other sheets it adds data but it overwrites sixth row and i dont wanna do that I would like to put this data in free row (not in the same row as in sheet1).

The error lies in your sub routine ValidarCampos. When you activate the userform that this code belongs to, you are 'activating' cell A3 of the active worksheet. In other words, that is the ActiveCell.

When you loop through your worksheets, you are still referring to the worksheet that the ActiveCell is on. You never set the active cell to another worksheet but you should do so. To get it to work you could change your code to something like this:

[VBA] ..
For i = 1 To Sheets.Count
'Use ws as worksheet(sheet number)

' First set the ActiveCell to be in the Worksheet that you are dealing with:
Worksheets(i).Range("A3").Activate

' Now continue with the rest of your code:
Do While Not IsEmpty(ActiveCell)
ActiveCell.Offset(1, 0).Activate
Loop
...[/VBA]

Note that you don't have to activate or select a cell to do something with it. In fact, it's usually a better idea not to do it. Your solution will work though.

And when this is done I would like to delete data added in sheets where cells in G column says "Zaseden" and is higlighted with red

You could go at least two ways with this one.
The first is to loop through the cell in the G column on each worksheet and test for the value Zaseden. If found delete the row and continue.
The second method uses the Find/FindNext method and is faster then the first method but most people find it a little more difficult to work with. It's not that tough though and with a little effort it can be mastered fairly quickly.
Here's an example:

[VBA]Sub SearchAndDelete()
'This routine loops through all the worksheets in the active workbook,
'searches for the value 'Zaseden' in column 7 (G)
'and deletes the rows where the value is found.
Dim wks As Worksheet
Dim rFoundResult As Range
Dim sFirstFound As String, sNextFound As String
Dim sWhat2search4 As String

'Search for what?
sWhat2search4 = "Zaseden"

For Each wks In ThisWorkbook.Worksheets
wks.Activate
wks.Range("G1").Select
Set rFoundResult = wks.Columns(7).Find(What:=sWhat2search4, after:=wks.Range("G1"), LookIn:=xlValues, _
LookAt:=xlWhole, SearchOrder:=xlByColumns, SearchDirection:=xlNext, _
MatchCase:=False)
If Not rFoundResult Is Nothing Then
sFirstFound = rFoundResult.Address
sNextFound = ""

'Delete the row
Set rFoundResult = rFoundResult.Offset(1, 0)
Rows(rFoundResult.Row - 1).Delete Shift:=xlUp

'Look for other matches and delete corresponding row if found
Do While (Not rFoundResult Is Nothing) And (sNextFound <> sFirstFound)
Set rFoundResult = wks.Columns(7).FindNext(after:=rFoundResult)
If Not rFoundResult Is Nothing Then
sNextFound = rFoundResult.Address
Set rFoundResult = rFoundResult.Offset(1, 0)
Rows(rFoundResult.Row - 1).Delete Shift:=xlUp
End If
Loop
End If
Next wks
End Sub[/VBA]

Hope that helps,

Rembo

[saban]

cool
i will try and let you know

[saban]

can you tell me more specific for first code what else should I write in, are these comments tellin me what to do

[saban]

actually i need to delete just cells from A to F and not whole row

[saban]

for that add data i wrote: [VBA] Worksheets(i).Range("A3").Activate [/VBA]
but i get error activate method of range class failed

[saban]

[VBA]Worksheets(i).Range("A3").Activate
Do While Not IsEmpty(ActiveCell)
ActiveCell.Offset(1, 0).Activate
Loop[/VBA]

I wrote code for search for empty cell like this but i get an error

[Rembo]

Hello saban,

Can you post a sample workbook? It will be easier for me to see where the code fails you and how to solve it.

Rembo

for that add data i wrote: [VBA] Worksheets(i).Range("A3").Activate [/VBA]
but i get error activate method of range class failed

[mdmackillop]

Try

[VBA]

Worksheets(i).Activate
Range("A3").Activate
Do While Not IsEmpty(ActiveCell)
ActiveCell.Offset(1, 0).Activate
Loop

[/VBA]

[mdmackillop]

But the quicker way avoids the loops
[VBA]
Cells(Range("A3:A65536").SpecialCells(xlCellTypeBlanks).Row, 1).Activate

[/VBA]

[Rembo]

But the quicker way avoids the loops

I agree, this is much nicer way to handle the problem but you'd still need a loop though to go through all the empty cells.
To top it off you could even adjust it to adapt for the number of available rows so the code is portable to the new office 12:

[VBA]
Cells(Range("A3:A" & Rows.Count).SpecialCells(xlCellTypeBlanks).Row, 1).Activate
[/VBA]

Note that you will need to build in an error trap in case no empty cells are found.

saban: theoretically your loop could error if all rows (in col A) were filled with a value. The code would try to offset 1 row down of A65536 to a non-existing row. If there's no danger of all rows being filled with data this can be ignored, otherwise you will have to build in an escape if the max row number is reached.

Rembo

[saban]

thnx guys I will try this and let you know and i will post a sample of my workbook

[saban]

Just run frmTomarDatos form

[Rembo]

Ok, I ran the form and fixed the activation error per the suggestion of mdmackillop. See the attachment.
Keep in mind that I don't understand your language (aren't they two languages actually?) so it's a little hard for me to understand what it exactly is that you want to happen.Is there anything else that has to be sorted?

Rembo

Just run frmTomarDatos form

[saban]

I need the data put into form "frmtomardatos" shown in first free cell of worksheet it still puts data in sheet1 into free row but in other sheets it adds data to same row as in sheet1 and i dont wanna do that i need this data in free row not to owervrite occupied row in sheet2 or sheet3 and so on

Thnx for all your help

[mdmackillop]

Change the subs in Rembos code to the following

[VBA]
Private Sub cmdAceptar_Click()
'Antes de ingresar los datos
'comprobamos que sean correctos
SearchAndDelete
ValidarCampos
End Sub

Private Sub ValidarCampos()

Dim BCell As Range
Dim sh As Worksheet

For Each sh In Sheets
sh.Activate
Set BCell = Cells(Range("A3:A65536").SpecialCells(xlCellTypeBlanks).Row, 1)

With BCell
.Offset(0, 0).Value = txtNombre * 1
.Offset(0, 1).Value = frmTomarDatos.txtApellidos.Value
.Offset(0, 2).Value = frmTomarDatos.txtEntidad.Value * 1
.Offset(0, 3).Value = frmTomarDatos.txtOficina.Value
.Offset(0, 4).Value = frmTomarDatos.txtControl.Value
.Offset(0, 5).Value = frmTomarDatos.txtCuenta.Value
End With
Next
Set BCell = Nothing
Set sh = Nothing
End Sub

Sub SearchAndDelete()
'This routine loops through all the worksheets in the active workbook,
'searches for the value 'Zaseden' in column 7 (G)
'and deletes the row where the value is found.
Dim wks As Worksheet
Dim rFoundResult As Range
Dim sWhat2search4 As String

'Search for what?
sWhat2search4 = "Zaseden"

For Each wks In ThisWorkbook.Worksheets
Do
Set rFoundResult = wks.Columns(7).Find(What:=sWhat2search4, After:=Range("G1"))
On Error Resume Next
rFoundResult.EntireRow.Delete
Loop Until rFoundResult Is Nothing
Next wks
End Sub

[/VBA]

[saban]

rFoundResult.EntireRow.Delete

I guess this deletes whole row but how could i delete just cells from A to F and cell AD

Because i have formulas in other cells that are reffering to this cells
thnx

[mdmackillop]

[VBA]

rFoundResult.Offset(, -6).Range("A1:F1").ClearContents
rFoundResult.Offset(, -6).Range("AD1").ClearContents

[/VBA]

[saban]

thnx i will try this