Saltar al contenido

JSDJSD

Exceler C
  • Contador de contenido

    2416
  • Unido

  • Última visita

  • Días con premio

    228

Todo se publica por JSDJSD

  1. Has realizado alguna prueba ? Cuando dices filtrar por 4 criterios a la vez, te refieres que siempre vas a poner los cuatro criterios, o puedes hacerlo por 1, 2,3 o los cuatro al mismo tiempo?
  2. Sub Macro1() Dim tablaRef As Range Dim UltimaFila As Long Dim UltimaColumna As Long ' Recogemos valores para las variables de UltimaFila y UltimaColumna With Sheets("Hoja1") UltimaFila = .Cells(.Rows.Count, "C").End(xlUp).Row UltimaColumna = .Cells(3, .Columns.Count).End(xlToLeft).Column Set tablaRef = .Range(.Cells(3, 3), .Cells(UltimaFila, UltimaColumna)) End With ' Seleccionamos la tabla de referencias tablaRef.Select End Sub No lo he probado, prueba y comenta
  3. El archivo PRUEBA.xlsm
  4. Bueno, prueba y comenta
  5. Si nadie te contesta antes, luego te lo miro
  6. No me he dado cuenta y te he contestado en el tema anterior, miralo y comenta
  7. Sub Limpiar(): Application.ScreenUpdating = False With Hoja1 .ClearArrows .Range("A1", "S" & .Range("S" & Rows.Count).End(xlUp).Row).Copy Destination:=Hoja7.Range("A1") End With With Hoja7.Range("A:S") uf = .Range("S" & Rows.Count).End(xlUp).Row .UnMerge .WrapText = False .Columns("A:S").AutoFit .Range("C3", "R" & uf).Select Selection.Cut Destination:=.Range("C2", "R" & uf - 1) For x = uf To 2 Step -1 If .Cells(x, 2) = "" Or .Cells(x, 3) = "" Then .Cells(x, 2).EntireRow.Delete End If Next x For y = 2 To .Range("S" & Rows.Count).End(xlUp).Row Cliente = .Range("A" & y): Orden = .Range("B" & y): Campo = .Range("S" & y) If .Cells(y + 1, 1) = "Nom_Cliente" Then .Cells(y + 1, 1) = Cliente: .Cells(y + 1, 2) = Orden: .Cells(y + 1, 19) = Campo .Cells(y + 1, 1).WrapText = False: .Cells(y + 1, 2).WrapText = False: .Cells(y + 1, 19).WrapText = False .Cells(y + 1, 1).Font.Bold = True: .Cells(y + 1, 2).Font.Bold = True: .Cells(y + 1, 19).Font.Bold = True End If Next y End With End Sub lotes_produccion (19) (1).xlsm
  8. Deja un ejemplo de como debe quedar y abre un tema nuevo
  9. Prueba y comenta Private Sub Worksheet_Change(ByVal Target As Range) Dim busca As Range Dim rg As Range Dim cont As Double Dim i As Integer If InStr(1, Target.Address, ":") = 0 And Not Intersect(Target, Range("D16:D110")) Is Nothing Then If Target.Offset(0, 2) = "" Then ' si la columna C esta vacia continuamos hoja = Range("W2") ' nombre de la hoja L = Split(Sheets(hoja).Cells(4, Columns.Count).End(xlToLeft).Address, "$") ' ultima columna llena Set rg = Sheets(hoja).Range("C5:" & L(1) & "4") ' rango de la tabla donde buscar 'cambie el No 2 por 4 pensando que es la fila Set busca = rg.Find(Target, LookIn:=xlValues, LookAt:=xlWhole) ' buscamos en el rango If busca Is Nothing Then Exit Sub ' si no lo encuentra sale cont = 1 Do While busca.Offset(cont, 0).Value <> "" ' mientras existan datos en la tabla Target.Offset(cont - 1, 3) = busca.Offset(cont, 0) ' columna donde pegara la informacion If cont = 1 Then Target.Offset(cont - 1, 3).Font.Bold = True ' negrita Target.Offset(cont - 1, 3).Font.Color = 6567712 ' color azul Target.Offset(cont - 1, 1) = Range("Ag2") 'Chr(149)'coloca el caracter indicado Target.Offset(cont - 1, 1).VerticalAlignment = xlTop ' alinear el simbolo en c arriba 'Target.Offset(cont - 1, 25) = Hoja ' nombre de la hoja, para saber de donde viene los datos Else Target.Offset(cont - 1, 3).Font.Bold = False ' quita negrita Target.Offset(cont - 1, 3).Font.Color = 0 ' quita color Target.Offset(cont - 1, 20) = "" ' borra coluna C ( donde capturamos la hoja " Target.Offset(cont - 1, 1) = "" End If cont = cont + 1 Loop For ini = 1 To Range("t1") Target.Offset(cont - 1, 0).Select If Range("t1") <= Target Then Exit For Else ActiveCell = Target + 1 End If With Hoja1 vuf = .Range("g" & .Rows.Count).End(xlUp).Row ' cambie la D x E donde copiara ahoara .PageSetup.PrintArea = .Range("e1:r" & vuf).Address(, , , 1) End With Exit Sub Next End If End If End Sub
  10. El archivo lotes_produccion (16).xls
  11. A ver si es esto lo que necesitas
  12. Pon ejemplo de cómo quedaria
  13. El botón puedes eliminarlo y ejecutar la macro como tu veas. Sub ExtraerDatos() Sheets("ejemplo").Cells.Clear Sheets("Sheet1").Rows.Copy Sheets("ejemplo").Rows Set hojaOrigen = ThisWorkbook.Sheets("Sheet1") Set hojaDestino = ThisWorkbook.Sheets("ejemplo") ultimaFila = hojaOrigen.Cells(hojaOrigen.Rows.Count, "A").End(xlUp).Row vCliente = "" vOrden = "" vProyecto = "" vComposicion = "" For i = 1 To ultimaFila If Trim(Left(hojaOrigen.Cells(i, 1).Value, 11)) = "Cliente :" Then vCliente = Mid(hojaOrigen.Cells(i, 1).Value, 12) Do While i <= ultimaFila And InStr(1, hojaOrigen.Cells(i, 1).Value, "Orden :") = 0 vCliente = vCliente & " " & hojaOrigen.Cells(i, 1).Value i = i + 1 Loop If i <= ultimaFila Then vCliente = Trim(Left(vCliente, InStr(1, vCliente, "Orden :") - 1)) hojaDestino.Range("P" & i + 2) = "Cliente" hojaDestino.Range("P" & i + 3) = vCliente hojaDestino.Columns("P").AutoFit vOrden = Mid(hojaOrigen.Cells(i, 1).Value, InStr(1, hojaOrigen.Cells(i, 1).Value, "Orden :") + Len("Orden :")) Do While i <= ultimaFila And InStr(1, hojaOrigen.Cells(i, 1).Value, "Proyecto :") = 0 vOrden = vOrden & " " & hojaOrigen.Cells(i, 1).Value i = i + 1 Loop If i <= ultimaFila Then vOrden = Trim(Left(vOrden, InStr(1, vOrden, "Proyecto :") - 1)) hojaDestino.Range("O" & i + 2) = "Orden" hojaDestino.Range("O" & i + 3) = vOrden hojaDestino.Columns("O").AutoFit vProyecto = Mid(hojaOrigen.Cells(i, 1).Value, InStr(1, hojaOrigen.Cells(i, 1).Value, "Proyecto :") + Len("Proyecto :")) hojaDestino.Range(" Q" & i + 2) = "Proyecto" hojaDestino.Range("Q" & i + 3) = vProyecto hojaDestino.Columns("Q").AutoFit Do While i <= ultimaFila And InStr(1, hojaOrigen.Cells(i, 1).Value, "Composicion :") = 0 i = i + 1 Loop If i <= ultimaFila Then vComposicion = Mid(hojaOrigen.Cells(i, 1).Value, InStr(1, hojaOrigen.Cells(i, 1).Value, "Composicion :") + Len("Composicion :")) hojaDestino.Range("R" & i + 1) = "Composicion" hojaDestino.Range("R" & i + 2) = vComposicion hojaDestino.Columns("R").AutoFit End If End If End If End If Next i EliminarFilasClienteComposicion End Sub Sub EliminarFilasClienteComposicion() Dim hoja As Worksheet Dim ultimaFila As Long Dim i As Long Set hoja = ThisWorkbook.Sheets("ejemplo") ultimaFila = hoja.Cells(hoja.Rows.Count, "A").End(xlUp).Row For i = ultimaFila To 1 Step -1 If InStr(1, UCase(hoja.Cells(i, 1).Value), "CLIENTE") > 0 Or InStr(1, UCase(hoja.Cells(i, 1).Value), "COMPOSICION") > 0 Then hoja.Rows(i).Delete End If Next i End Sub lotes_produccion (16).xls
  14. Si nadie te da solución antes mañana lo intento
  15. Cambia estas dos lineas en tu còdigo txt_dani_general.Value = CDbl(txt_tejido_tapa.Value) + CDbl(txt_referencia.Value) '<<<<<<<<<<<<<<<<<<<< txt_suma.Value = CDbl(txt_suma) / 100000 ' <<<<<<<<<<<<<<<<<<<<< Private Sub BT_BUSCARARTICULO_Click() Dim Rango As Range Dim suma As Double Set Rango = Sheets("PRESUPUESTO1").Range("C4:CJ500000") txt_referencia = Application.WorksheetFunction.VLookup(txt_escandallo.Value, Rango, 4, 0) txt_articulo = Application.WorksheetFunction.VLookup(txt_escandallo.Value, Rango, 5, 0) txt_tejido_tapa = Application.WorksheetFunction.VLookup(txt_escandallo.Value, Rango, 82, 0) txt_comision = Application.WorksheetFunction.VLookup(txt_escandallo.Value, Rango, 50, 0) '............................... <<<<<<<<<<Resto de tu còdigo '............................... On Error Resume Next txt_dani_general.Value = txt_tejido_tapa.Value & txt_referencia.Value '<<<<<<<<<< Modificar txt_suma.Value = txt_suma / 100000 '<<<<<<<<<< Modificar Me.LISTA.RowSource = "ARTICULOS9" Me.LISTA.ColumnCount = 9 End Sub
  16. Private Sub Worksheet_Change(ByVal Objetivo As Range) With Hoja1 If Not Intersect(Objetivo, .Range("E3")) Is Nothing Then Application.EnableEvents = False nuevoValor = Objetivo ultimaFila = .Cells(.Rows.Count, "D").End(xlUp).Row For i = 4 To ultimaFila textoActual = .Cells(i, "D") posicionPunto = InStr(1, textoActual, ".") If posicionPunto > 0 Then textoDespuesPunto = Mid(textoActual, posicionPunto + 1) .Cells(i, "D") = nuevoValor & "." & textoDespuesPunto End If nuevoValor = nuevoValor + 1 Next i Application.EnableEvents = True End If End With End Sub Cambio automatico de numeros.xlsm
  17. En cuanto tenga tiempo te mando un ejemplo
  18. Tendrías un formulario para introducir, modificar y borrar los datos y otro en el que te muestra todas las anotaciones de los clientes, personas o de lo que se trate, dicho formulario sería más o menos este, pero claro estoy seguro que hay que añadirle algunas cosillas ya que los importes por ejemplo no los veo en el archivo que has subido.. y en el de destino si que pones PAGADO y una sumatoria al final.
  19. Una pregunta ? que motivo hay para hacerlo en dos archivos diferentes? si de lo que trata es de sacar un informe y mandarlo a ..... se podría hacer todo en el mismo archivo. En caso afirmativo tendrías algún problema en cambiar la estructura de tus datos?
×
×
  • Crear nuevo...

Información importante

Echa un vistazo a nuestra política de cookies para ayudarte a tener una mejor experiencia de navegación. Puedes ajustar aquí la configuración. Pulsa el botón Aceptar, si estás de acuerdo.