rolano

Hola, se mas explicito, donde no te funcionó. Tienes que ver que el comentario este en la celda del código y el texbox.

n = Application.WorksheetFunction.Match(Me.cbo_Categoria.Value, sh.Range("1:1"), 0) If n = "" Then MsgBox " Sin Dato " else Me.cbo_Tipo.Clear For i = 2 To Application.WorksheetFunction.CountA(sh.Cells(1, n).EntireColumn) Me.cbo_Tipo.AddItem sh.Cells(i, n).Value Next i en If Hola, revisa el código.

TextBox1 = Range("A7").Comment.Text Hola prueba así.

Hola, donde te da el error. Recuerda que en el archivo origen donde esta la macro tienes que tener una hoja con nombre "analysis" y en el archivo destino una hoja con nombre "sheet1".

Sub AleaIactaEst() Dim cuant As Integer: cuant = Range("B1") Dim aleat As Integer Dim r As Range: Set r = Range("F2:F15") Dim q, i As Integer Worksheets(1).Range("F2:H15").ClearContents '-------------------------------------------------------------------------------------- 'Aleatorios '-------------------------------------------------------------------------------------- q = 0 Do aleat = Application.WorksheetFunction.RandBetween(Range("B2"), Range("B3")) q = q + 1: If q > cuant Then Exit Do r(q, 1) = aleat If q > 1 Then For i = 1 To q - 1 If r(i, 1) = aleat Then r(q, 1) = "" q = q - 1 Exit For End If Next End If Loop '-------------------------------------------------------------------------------------- Range("F2:F15").Sort Key1:=Range("F2:F15"), Order1:=xlAscending Cells(17, 6) = Application.WorksheetFunction.Sum(ActiveSheet.Range("F2:F15")) '-------------------------------------------------------------------------------------- Range("F18").Formula = "=MOD(SUM(F2:F15)-1,9)+1" Range("F18").Value = Range("F18").Value 'Boorar esta linea si quieres que se vea la formula. Exit Sub End Sub Hola, prueba con el código añadido.

ActiveWorkbook.Sheets(1).ChartObjects("Grafico_1").Select Hola, prueba así

'Option Explicit Option Base 1 Public Sub VENTAS_SECCION_MES() Dim sql As String, SheetName As String Dim AÑO, CENTRO, SECCION, MES As String Dim strConectar As String Sheets("Ventas").Select Range("C5").Select Application.ScreenUpdating = False AÑO = Range("C2").Value CENTRO = Range("A3").Value MES = Range("C3").Value SECCION = ActiveCell.Offset(0, -2).Value 'Application.Cursor = xlWait Dim wb As Workbook, ws As Worksheet 'Venta de un año, un mes, una tienda y una sección sql = "SUM[TOT_VENTAS]) AS TOTAL_VENTAS FROM PRESUPUESTO_VENTAS WHERE,[ANYO] = 'AÑO'), AND ([COD_CC] = 'CENTRO'), AND ([SECCION] = SheetName = "Ventas" Set wb = ActiveWorkbook Set ws = wb.ActiveSheet ws.Name = SheetName ' Poner los datos particulares de la conexión Dim Con As New ADODB.Connection Con.Open "provider=IBMDA400;data source=172.16.1.1;Default Collection=-----;USER ID=---;PASSWORD=------;" DownloadQuery Con, sql, SheetName Con.Close Set Con = Nothing Set wb = Nothing Set ws = Nothing Application.Cursor = xlDefault Application.ScreenUpdating = False End Sub Private Sub DownloadQuery(Con As ADODB.Connection, sql As String, SheetName As String) Dim Cmd As ADODB.Command Dim Rs As ADODB.Recordset Set Cmd = New ADODB.Command Set Cmd.ActiveConnection = Con Cmd.CommandText = sql Dim ws As Worksheet, fld As ADODB.Field Set ws = Worksheets(SheetName) 'Set Rs = Cmd.Execute() Set Rs = New ADODB.Recordset Rs.Open "PRESUPUESTO_VENTAS", Con, adOpenKeyset, adLockOptimistic, adCmdTableDirect ' Me trae el dato de la Consulta SQL 'ActiveCell.CopyFromRecordset Rs 'LimpiaRango ws.Range("C5:C18").ClearContents Rs.MoveFirst Do While Not Rs.EOF dFecha = Rs.Fields(12) 'Año wsFecha = Val(ws.Range("C2")) dCentro = Rs.Fields(2) 'Centro wsCentro = Val(ws.Range("A3")) dSeccion = Rs.Fields(5) 'Seccion dMes = Rs.Fields(15) 'Mes wsMes = Val(Range("C3")) For I = 5 To 18 wsSeccion = Val(Range("A" & I)) If dSeccion = wsSeccion And dMes = wsMes Then If dFecha = wsFecha And dCentro = wsCentro Then If Val(ws.Range("A" & I)) = Rs.Fields(5) Then Valor = Val(ws.Range("C" & I)) + Rs.Fields(9) ws.Range("C" & I) = Valor End If End If End If Next I Rs.MoveNext Loop Set fld = Nothing Set Rs = Nothing End Sub Hola, trata de declarar las variables.

'Option Explicit Option Base 1 Public Sub VENTAS_SECCION_MES() Dim SheetName As String Dim strConectar As String Dim ws As Worksheet Dim wb As Workbook Dim Cmd As ADODB.Command Dim Rs As ADODB.Recordset Application.ScreenUpdating = False Sheets("Ventas").Select 'Range("C5").Select Application.Cursor = xlWait SheetName = "Ventas" Set wb = ActiveWorkbook Set ws = wb.ActiveSheet ws.Name = SheetName ' Poner los datos particulares de la conexión Dim Con As New ADODB.Connection Con.Open "provider=IBMDA400;data source=172.16.1.1;Default Collection=-----;USER ID=---;PASSWORD=------;" ' Dim Con As New ADODB.Connection ' strConectar = ThisWorkbook.Path & "\BDVentas.mdb" ' With Con ' .ConnectionString = _ ' "Provider=Microsoft.ACE.OLEDB.12.0" ' .Open "Provider=Microsoft.Jet.OLEDB.4.0; " & _ ' "Data Source=" & strConectar & ";" & _ ' "Jet OLEDB:Database Password=Ventas" ' End With Set ws = Worksheets(SheetName) Set Rs = New ADODB.Recordset Rs.Open "PRESUPUESTO_VENTAS", Con, adOpenKeyset, adLockOptimistic, adCmdTableDirect ' Me trae el dato de la Consulta SQL 'ActiveCell.CopyFromRecordset Rs 'LimpiaRango ws.Range("C5:C18").ClearContents Rs.MoveFirst Do While Not Rs.EOF dFecha = Rs.Fields(12) 'Año wsFecha = Val(ws.Range("C2")) dCentro = Rs.Fields(2) 'Centro wsCentro = Val(ws.Range("A3")) dSeccion = Rs.Fields(5) 'Seccion dMes = Rs.Fields(15) 'Mes wsMes = Val(Range("C3")) For I = 5 To 18 wsSeccion = Val(Range("A" & I)) If dSeccion = wsSeccion And dMes = wsMes Then If dFecha = wsFecha And dCentro = wsCentro Then If Val(ws.Range("A" & I)) = Rs.Fields(5) Then Valor = Val(ws.Range("C" & I)) + Rs.Fields(9) ws.Range("C" & I) = Valor End If End If End If Next I Rs.MoveNext Loop Con.Close Set Rs = Nothing Set Con = Nothing Set wb = Nothing Set ws = Nothing Application.Cursor = xlDefault Application.ScreenUpdating = True End Sub Hola a todos, revisa este código adjunto, lo he corrido en un archivo de access. Tienes que ver como esta su base de datos los campos afectados deben ser números.

Hola Cecilio, adjunto el código para que lo reescribas en tu proyecto.

Sub MAC() Application.ScreenUpdating = False Set H1 = Sheets("Hoja1") Set H2 = Sheets("Hoja3") ultimfb = H2.Range("B" & Rows.Count).End(xlUp).Row + 1 H2.Range("B4" & ": AV" & ultimfb).Clear H1.Activate Range("A9").Select Do While ActiveCell <> "FIN" If Len(ActiveCell.Value) = 6 Then ultimfd = H2.Range("B" & Rows.Count).End(xlUp).Row + 1 ActiveCell.Offset(0, 0).Copy H2.Range("B" & ultimfd).PasteSpecial xlValues End If ActiveCell.Offset(1, 0).Select Loop H2.Activate 'ultimf = Range("AV" & Rows.Count).End(xlUp).Row For i = 4 To H2.Range("b" & Rows.Count).End(xlUp).Row Set b = H1.Range("A:A").Find(H2.Cells(i, "b"), lookat:=xlPart) If Not b Is Nothing Then H1.Range("B" & b.Row).Copy H2.Cells(i, "C").PasteSpecial xlValues If Not b Is Nothing And H1.Range("C" & b.Row) > 0 Then H1.Range("C" & b.Row).Copy H2.Cells(i, "D").PasteSpecial xlValues If Not b Is Nothing And H1.Range("D" & b.Row) > 0 Then H1.Range("D" & b.Row).Copy H2.Cells(i, "E").PasteSpecial xlValues If Not b Is Nothing And H1.Range("E" & b.Row) > 0 Then H1.Range("E" & b.Row).Copy H2.Cells(i, "F").PasteSpecial xlValues If Not b Is Nothing And H1.Range("F" & b.Row) >= 0 Then H1.Range("F" & b.Row).Copy H2.Cells(i, "G").PasteSpecial xlValues If Not b Is Nothing And H1.Range("G" & b.Row) >= 0 Then H1.Range("G" & b.Row).Copy H2.Cells(i, "H").PasteSpecial xlValues End If End If End If End If End If End If Next i ' a raiz de que en las columnas G, H y demas columnas hacia la derecha ya no me copia valores que sean mayores a cero (0) me vi en la necesidad 'de entrar nuevamente a un nuevo ciclo ignoro si el if en vba tenga limitante ' For t = 4 To H2.Range("b" & Rows.Count).End(xlUp).Row ' Set b1 = H1.Range("A:A").Find(H2.Cells(t, "b"), lookat:=xlPart) ' ' If Not b1 Is Nothing And H1.Range("f" & b.Row) > 0 Then ' ' H1.Range("F" & b.Row).Copy ' H2.Cells(t, "G").PasteSpecial xlValues ' ' If Not b1 Is Nothing And H1.Range("f" & b.Row) > 0 Then ' ' H1.Range("G" & b.Row).Copy ' H2.Cells(t, "H").PasteSpecial xlValues ' ''MsgBox "Fin" ' End If ' End If 'Next t Application.CutCopyMode = False Application.ScreenUpdating = True End Sub Hola Cecilio, la condición tiene que ser mayor igual a 0, porque en la hoja 1 tienes valores (0)..

Private Sub ListBox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean) ListBox1.BoundColumn = 2 ListBox1.TextColumn = 2 Hoja3.Range("D9") = ListBox1.Value Exit Sub End Sub Hola Xanito, copia este código. Saludos @Gerson Pineda

Hola Sretamalb, revisa el adjunto. saludos @Antoni. Prueba (2).xlsm

Sub IrACataluña() ' ' IrACataluña Macro ' Ir a Cataluña ' ' Sheets("Cataluña").Select Range("C2:C5").Select Selection.Copy Range("A1").Select 'celda donde queires que se estacione. Sheets("Datos").Select Range("C2").Select ActiveSheet.Paste Application.CutCopyMode = False Range("A1").Select End Sub Sub IrAComunidadValenciana() ' ' IrAComunidadValenciana Macro ' Ir a Comunidad Valenciana Worksheets("Comunidad Valenciana").Range("C2:C6").Copy Worksheets("Datos").Range("C2") End Sub Hola, así para todas las rutinas. La segunda macro es mas corta.

'Application.CutCopyMode = False Sub IrACataluña() ' ' IrACataluña Macro ' Ir a Cataluña ' ' Sheets("Cataluña").Select Range("C2:C5").Select Selection.Copy Sheets("Datos").Select Range("C2").Select ActiveSheet.Paste Application.CutCopyMode = False Range("A1").Select End Sub Hola, tienes que colocar Application.CutCopyMode = False

Public Sub copiarWs() Dim Q& Set ws1 = ActiveSheet On Error Resume Next ws2 = "Selecciona el libro a procesar." MsgBox ws2, vbOKOnly ws2 = Application.GetOpenFilename(Title:=ws2) If ws2 = False Then Exit Sub On Error GoTo 0 Set ws2 = Workbooks.Open(ws2, ReadOnly:=True).Sheets(1) If [c12] = "" Then MsgBox "Libro sin información." GoTo Fin End If ReDim Mat(1 To 4) Q = Range([a6], Cells(Rows.Count, "c").End(xlUp)).Rows.Count Mat(1) = Application.Transpose(ws2.[a6].Resize(Q)) Mat(2) = Application.Transpose(ws2.[c6].Resize(Q)) Mat(3) = Application.Transpose(ws2.[d6].Resize(Q)) Mat(4) = Application.Transpose(ws2.[g6].Resize(Q)) LastRow = ws1.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row ws1.Range("b" & LastRow).Resize(Q, UBound(Mat)) = Application.Transpose(Mat) 'ws1.[b3].Resize(Q, UBound(Mat)) = Application.Transpose(Mat) Fin: ws2.Parent.Close False ws1.[a4].CurrentRegion.Columns.AutoFit End Sub Prueba con la modificación