Buenos compañer@s, a ver si me podéis ayudar con esta macro. En esencia se conecta al AS400 de mi empresa (previa vista generada) y me trae datos a través de una consulta SQL. La macro funciona bien y no tengo problemas. El tema es que no sé trabajar recorriendo el  RECORDSET y me toca ingeniármelas con un bucle Do Loop para que me vaya generando los datos que quiero. Os detallo la macro y las celdas donde me trae los datos. Lo que me gustaría es poder establecer el rango("C5:C18") de alguna forma en el RECORDSET para que lo hiciese de golpe y no recorriendo celda a celda. Asimismo, si por ejemplo, quisiese ampliar el rango de la matriz de datos y meter, por ejemplo, en D3 el mes 11, en D4 el mes 12, que me trajese los datos.

Muchas gracias

 

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

Sheets("Ventas").Select
Range("C5").Select

Do Until ActiveCell.Offset(0, -1) = ""

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 = _
"SELECT SUM(TOT_VENTAS) AS TOTAL_VENTAS " & _
  "FROM PRESUPUESTO_VENTAS " & _
 "WHERE ANYO = " & AÑO & " AND COD_CC = " & CENTRO & " AND SECCION= " & SECCION & " AND MES= " & MES & " "

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

ActiveCell.Offset(1, 0).Select

Con.Close

Loop

Set Con = Nothing
Set wb = Nothing
Set ws = Nothing

Application.Cursor = xlDefault

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()

' Me trae el dato de la Consulta SQL

ActiveCell.CopyFromRecordset Rs

Set fld = Nothing
Set Rs = Nothing

End Sub

 

Armando, sube el archivo de ejemplo.

No creo que nadie te quiera ayudar si le haces introducir a mano todos esos datos...

Gracias.

Lo siento. Adjunto archivo.

VENTAS.xlsb

Hola

Es complicado terminar de entenderte sin tener acceso a tu base de datos. Sugiero colocar en una hoja de Excel una copia fiel de una parte de los registros de la tabla "PRESUPUESTO_VENTAS" para poder entender tu bucle y lo de los parámetros usados en la sentencia SQL. No olvidar una mejor y detallada explicación. OJO, repito, parte de los datos de la tabal, tal cual, no de los datos extraídos como has adjuntado.

Buenos días, disculpar mi torpeza

Adjunto de nuevo fichero con una pestaña nueva ("BD") donde están los datos (parte lógicamente) a los que ataca la conexión.

 

VENTAS.xlsb

'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.

Muchas gracias César.  Me conecto al curro y me pongo con ello.

Da gusto que gente como vosotros (todos los del foro que entendéis a fondo VBA) nos ayudéis al resto a mejorar. Esto no tiene precio. En serio.

Buenas de nuevo, me da fallo pero entiendo que es porque algo estoy haciendo mal.

 

Creo que para mi sería más fácil trabajarlo sobre la estructura del módulo que tenía inicialmente. Tener en cuenta que me estoy metiendo ahora en este tipo de programación (atacar desde excel bbdd ) y estoy muy verde.

Muchas gracias y disculpar

'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.

Saludos @ArmandoR, prueba asi

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
    
    Sheets("Ventas").Select
    
    AÑO = Range("C2").Value
    CENTRO = Range("A3").Value
    MES = Range("C3").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 = _
    "SELECT SECCION, SUM(TOT_VENTAS) AS TOTAL_VENTAS " & _
      "FROM PRESUPUESTO_VENTAS " & _
     "WHERE ANYO = " & AÑO & " AND COD_CC = " & CENTRO & " AND MES = " & MES & " " & _
     "GROUP BY 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

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
    Dim nFilFin As Double
    Dim rCelda As Range
    Dim nSeccion As Double
    
    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()
    
    nFilFin = ws.Range("A" & Rows.Count).End(xlUp).Row
    
    ' Me trae el dato de la Consulta SQL
    
    Do While Not Rs.EOF
        nSeccion = Rs.Fields("SECCION") 'Seccion
        
        For Each rCelda In ws.Range("A5:A" & nFilFin)
            If CDbl(rCelda.Value) = nSeccion Then
                rCelda.Offset(0, 2).Value = Rs.Fields("TOTAL_VENTAS")
                Exit For
            End If
        Next
        Rs.MoveNext
    Loop
    
    
    Set fld = Nothing
    Set Rs = Nothing

End Sub

el cambio lo realice sobre tu codigo del primer mensaje, recuerda que sin la base de datos es mas complicado, en esencia es lo mismo, realizas la consulta agrupando por SECCION y luego simplemente buscas cada SECCION en la tabla y colocas su total

 

Me funciona a la perfección

Muchas gracias por vuestro asesoramiento.

Vuelvo a repetirlo, es un placer estar en un foro como este con gente tan profesional y altruista como vosotros