Formulario con numero único y consecutivo

Si bien no es un formulario pero te puede servir de idea. El codigo es de un alta de remito el cual genera un codigo unico e irrepetible haciendo una copia de la hoja facturada creando esa hoja y la hoja anterior la deja en blanco con su numero correspondiente.

Sub agregar_hoja()
Application.ScreenUpdating = False
If Range("RemitoX") > 0 Then
Range("a1:l33").Select
Selection.Copy
Sheets.Add After:=ActiveSheet
ActiveSheet.Name = "Remito" & " " & "Nº" & " " & Range("RemitoX").Value
Range("a1:l33").Select
ActiveSheet.Paste
Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
Columns("A:A").ColumnWidth = 10.71
Columns("B:B").ColumnWidth = 46
Columns("C:C").ColumnWidth = 10
Columns("D:D").ColumnWidth = 13
Columns("E:F").ColumnWidth = 10.71
Columns("G:G").ColumnWidth = 2
Columns("H:H").ColumnWidth = 2
Columns("I:I").ColumnWidth = 4.57
Rows("28:28").RowHeight = 15.75
Range("b3").Select
ActiveSheet.Shapes("botón 3").Delete
ActiveSheet.Shapes("botón 4").Delete
ActiveSheet.Shapes("botón 5").Delete
' ActiveSheet.Protect
Application.PrintCommunication = False
With ActiveSheet.PageSetup
.PrintTitleRows = ""
.PrintTitleColumns = ""
End With
Application.PrintCommunication = True
ActiveSheet.PageSetup.PrintArea = ""
Application.PrintCommunication = False
With ActiveSheet.PageSetup
.LeftHeader = ""
.CenterHeader = ""
.RightHeader = ""
.LeftFooter = ""
.CenterFooter = ""
.RightFooter = ""
.LeftMargin = Application.InchesToPoints(0.7)
.RightMargin = Application.InchesToPoints(0.7)
.TopMargin = Application.InchesToPoints(0.75)
.BottomMargin = Application.InchesToPoints(0.75)
.HeaderMargin = Application.InchesToPoints(0.3)
.FooterMargin = Application.InchesToPoints(0.3)
.PrintHeadings = False
.PrintGridlines = False
.PrintComments = xlPrintNoComments
.PrintQuality = 1200
.CenterHorizontally = False
.CenterVertically = False
.Orientation = xlLandscape
.Draft = False
.FirstPageNumber = xlAutomatic
.Order = xlDownThenOver
.BlackAndWhite = False
.Zoom = 100
.PrintErrors = xlPrintErrorsDisplayed
.OddAndEvenPagesHeaderFooter = False
.DifferentFirstPageHeaderFooter = False
.ScaleWithDocHeaderFooter = True
.AlignMarginsHeaderFooter = True
.EvenPage.LeftHeader.Text = ""
.EvenPage.CenterHeader.Text = ""
.EvenPage.RightHeader.Text = ""
.EvenPage.LeftFooter.Text = ""
.EvenPage.CenterFooter.Text = ""
.EvenPage.RightFooter.Text = ""
.FirstPage.LeftHeader.Text = ""
.FirstPage.CenterHeader.Text = ""
.FirstPage.RightHeader.Text = ""
.FirstPage.LeftFooter.Text = ""
.FirstPage.CenterFooter.Text = ""
.FirstPage.RightFooter.Text = ""
End With
Application.PrintCommunication = True
Sheets("Resumen").Select
Rows("7:7").Select
'range("a7:g7").Select
' ActiveSheet.Unprotect
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Range("a7").Select
Selection.NumberFormat = "X - 0000000"
Sheets("Remito").Select
Range("b8").Select
Selection.Copy
Sheets("resumen").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:="", SubAddress:= _
"'Remito" & " " & "Nº" & " " & Range("RemitoX") & "'!A1", TextToDisplay:="Remito" & " " & "Nº" & " " & Range("RemitoX")
Range("b7").Select
Selection.NumberFormat = "dd/mm/yyyy"
Sheets("Remito").Select
Range("J3").Select
Selection.Copy
Sheets("resumen").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("c7").Select
Selection.NumberFormat = "HH:MM:SS"
Sheets("Remito").Select
Range("J4").Select
Selection.Copy
Sheets("resumen").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("d7").Select
Selection.NumberFormat = "0"
Sheets("Remito").Select
Range("e8").Select
Selection.Copy
Sheets("resumen").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("e7").Select
Sheets("Remito").Select
Range("b9").Select
Selection.Copy
Sheets("resumen").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("f7").Select
Sheets("Remito").Select
Range("b10").Select
Selection.Copy
Sheets("resumen").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("g7").Select
Selection.Style = "Currency"
Selection.NumberFormat = "$ #,##0.00"
Sheets("Remito").Select
Range("e31").Select
Selection.Copy
Sheets("resumen").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("a8").Select
Application.CutCopyMode = False
ActiveWorkbook.Worksheets("Resumen").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Resumen").Sort.SortFields.Add Key:=Range("A7:A1048567"), _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("Resumen").Sort
.SetRange Range("A6:g1048567")
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Set h1 = Sheets("Remito")
Set h2 = Sheets("Salida")
i = 13
u2 = 7
Do While h1.Cells(i, "A") <> ""
h2.Rows(7).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromRightOrBelow
h2.Cells(u2, "A") = h1.Range("B8") 'Remito
h2.Cells(u2, "B") = h1.Cells(i, "A") 'cod
h2.Cells(u2, "C") = h1.Cells(i, "B") 'desc
h2.Cells(u2, "D") = h1.Range("J3") 'fecha
h2.Cells(u2, "E") = h1.Cells(i, "C") 'cantidad
h2.Cells(u2, "F") = h1.Range("E8") 'cliente
h2.Cells(u2, "G") = h1.Cells(i, "E") 'monto
i = i + 1
Loop
MsgBox "Datos enviados a la hoja salida"
Sheets("Remito").Select
Range("b8").Select
End If
Sheets("Remito").Select
Range("e8").ClearContents
Range("a13:a25").ClearContents
Range("c13:c25").ClearContents
Range("RemitoX") = Range("RemitoX") + 1
Range("b8").Select
Application.ScreenUpdating = True
End Sub

No entendí, esto que me pasas,¿generaría una hoja nueva con un nuevo numero? ¿Y así cada vez que haga un remito me va a generar una hoja nueva?

GRACIAS

Exacto. Cada vez que hagas un nuevo remito hace una hoja nueva. Deberías ajustarlo a las celdas de tu remito.

No me sirve, yo quiero (si es que se puede) que sea en forma automática, si tengo que hacer algo como ajustar las celdas es más simple y cambiándole el numero de a uno en forma progresiva. Muchas gracias igual.

No le tienes que cambiar el número ni nada por el estilo. Lo hace solo. Aumenta el número del remito cada vez que se crea un remito nuevo. Lo de cambiar o adaptar esta macro me refería a que en las celdas que se hacen referencia en esta va a diferir en donde tengas tus propios datos.

¡Gracias! 

Lo que yo necesito es que cuando pongo a imprimir por ejemplo 20 formularios que cada formulario vaya cambiando el numero de remito solo... si tengo que correr una macro o hacer algun paso previo antes de imprimir cada formulario seria lo mismo que vaya cambiando el numero de remito uno por uno.

GRACIAS.

Espero que esta vez pueda dar en la tecla. De tanto investigar e ir probando salió esta rutina que " creo" es lo que busca.

Sub Imprimir ()

Dim n as variant

n= inputbox("Ingresé la cantidad de remitos que desea imprimir")

For i=1 to n

Activesheet.printout, copies:=1, printarea:= false

If Ranger("b8")>0 then

Ranger("b8")= Ranger("b8")+1

End if

Next

End sub.

Donde dice Ranger("b8") cámbialo en donde se encuentra tu celda autonumerica

Lo que hace es pedir que ingreses el total de remitos a imprimir. Solo va aumentando la numeración y va imprimiendo en forma correlativa.

Hola, ¿dónde debo pegar esta macro? Porque abrí el editor de VB la pegue en la hoja donde se encuentra la planilla hice los cambios de la celda de referencia y la cantidad a imprimir y no salio nada. Por favor indicame si hice algo mal.

GRACIAS

Sub Imprimir ()
Dim n as variant
n= inputbox(5)
For i=1 to n
Activesheet.printout, copies:=1, printarea:= false
If Ranger("r4")>0 then
Ranger("r4")= Ranger("r4")+1
End if
Next
End sub.

Insertas un modulo nuevo y la pegas ahí

Esta es la macro correcta

Sub Imprimir()
Dim nf As Variant
nf = InputBox("Ingrese cantidad de remitos a imprimir")
For i = 1 To nf
ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True, _
IgnorePrintAreas:=True
If Range("a1") > 0 Then
Range("r4") = Range("r4") + 1
End If
Next
End Sub

Si tienes áreas seleccionadas para imprimir debes poner la opción IgnorePrintAreas:=True en falso quedandote de esta manera IgnorePrintAreas:=false

Donde dice If Range("a1") > 0 Then debe decir If Range("r4") > 0 Then

Hice como dijiste, pero no funciona, la celda queda vacía no pone ningún numero.

En la celda r4 debes tener el numero con el que comienza el remito. Por ejemplo si el remito empieza con el 5 entonces en r4 debes coloar el 5. y modifica en el if el rango a1 por r4.

Enviame la hoja al correo [email protected]

Corregí la macro, pero igual sigue sin funcionar . te paso la imagen.

GRACIAS