Wend without While, second set of eyes please?

Question

Trying to modify my excel export to look like the colored imaged posted below.

Answer 1

There’s not enough code to say for sure …

Is there a statement somewhere like

Set rsEXHuddle = db.OpenRecordset("QueryOrTable", dbOpenDynaset) ?

Are there any records in it?

  

---

peter n roth - http://PNR1.com, Maybe some useful stuff

Answer 2

My apologies, this post is an extension to: https://social.msdn.microsoft.com/Forums/en-US/922ff730-7124-413a-a86f-465db226c1d7/export-data-to-excel-in-a-specific-format?forum=accessdev

I'm trying to make a button that exports my data in a specific format. So far my report is able to make this happen:

 and I need it to look like this (the color is easy, just the layout of the table is hard):

Here's the whole code I'm trying to alter:

Dim xlApp As Object
Dim xlWB As Object
Dim xlWS As Object
Dim db As DAO.Database
Dim rsEXHuddle As DAO.Recordset
Dim strSQL As String
Dim x As Long

On Error GoTo errHandler
Set db = CurrentDb()
Set xlApp = CreateObject("Excel.Application")
Set xlWB = xlApp.Workbooks.Add

  If IsNull(txtshDate) Or Me.txtshDate.Value = "" Then
        MsgBox "NULL BOX", vbCritical, "REQUIRED FIELD"
        Else
        
        strSQL = "SELECT [CAP] AS CPCT , " _
        & " [DISCHARGES] AS DCHRGS , " _
        & " [EarlyDC] AS EDSG , " _
        & " [LateDC] AS LDC , " _
        & " [shEDDecisionToDepart] AS EDDTD , " _
        & " [shCVEarlyDCPrediction] AS CVEDCP , " _
        & " [shSurg_TranEarlyDCPrediction] AS STEDCP , " _
        & " [shPsych_RehabEarlyDCPrediction] AS PREDCP , " _
        & " [shMed_OncEarlyDCPrediction] AS MOEDCP , " _
        & " [WOCN] AS WNDCR , " _
        & " [shLateLabAssist] AS LABAST , " _
        & " [EVS_PM_STAFFING] AS EVSSTFNG , " _
        & " [shRTWalker] AS RTWLKR " _
        & " FROM qryServiceHuddleReport"
          
        End If
        
        Set rsEXHuddle = db.OpenRecordset(strSQL, dbOpenSnapshot)
        Set xlWS = xlWB.Sheets(1)

        xlWS.Cells(1, 1) = "CAPACITY %"
        xlWS.Cells(1, 2) = "TOTAL DISCHARGES #s"
        xlWS.Cells(1, 3) = "Before / <1pm"
        xlWS.Cells(1, 4) = "After/>5pm"
        xlWS.Cells(1, 5) = "ED Decision to Depart (minutes)"
        xlWS.Cells(1, 6) = "Card/Vasc"
        xlWS.Cells(1, 7) = "Surg/Trans"
        xlWS.Cells(1, 8) = "Psych/Rehab"
        xlWS.Cells(1, 9) = "Med/Onc"
        xlWS.Cells(1, 10) = "WOCN: Total; New; Unseen >24hrs"
        xlWS.Cells(1, 11) = "LAB: Nurse Draw Assists waiting >1hr as of 10:30"
        xlWS.Cells(1, 12) = "EVS pm staffing"
        xlWS.Cells(1, 13) = "RT Walkers"
        
       ' With rsEXHuddle
       ' xlWS.Cells(1, 1) = !DONTKNO
       ' End With
        
        'xlWS.Range(xlWS.Cells(1, 1), xlWS.Cells(1, 6)).Font.Bold = True
        'xlWS.Cells(1, 1) = "DATE"
        'xlWS.Cells(1, 2) = "UNIT"
        'xlWS.Cells(1, 3) = "AREA"
        'xlWS.Cells(1, 4) = "STANDARD REQUIREMENT"
        'xlWS.Cells(1, 5) = "NON-CONFORMITY DETAILS"
        'xlWS.Cells(1, 6) = "CORRECTIVE ACTION"
        'xlWS.Range(xlWS.Cells(1, 1), xlWS.Cells(1, 6)).Font.Bold = True
        
        'add data
        xlWS.Range("A2").CopyFromRecordset rsEXHuddle
        x = rsEXHuddle.RecordCount
        rsEXHuddle.Close
        

        'format
        xlWS.Range(xlWS.Cells(1, 1), xlWS.Cells(1, 6)).HorizontalAlignment = 3
        xlWS.Range(xlWS.Cells(2, 1), xlWS.Cells(x + 1, 2)).HorizontalAlignment = xlCenter
        xlWS.Range(xlWS.Cells(2, 3), xlWS.Cells(x + 1, 6)).HorizontalAlignment = xlLeft
        xlWS.Range(xlWS.Cells(1, 1), xlWS.Cells(x + 1, 13)).Borders.LineStyle = xlContinuous
        xlWS.Columns("A:M").AutoFit

'remove extra tabs
If xlWB.Sheets.Count > 1 Then
With xlWB
On Error Resume Next
    .Sheets("Sheet1").Delete
    .Sheets("Sheet2").Delete
    .Sheets("Sheet3").Delete
On Error GoTo 0
End With
Else
'xlWB.Close , False
xlApp.Visible = True
Exit Sub
End If

errExit:
    Set rsEXHuddle = Nothing
    Set db = Nothing
    Set xlWS = Nothing
    Set xlWB = Nothing
    Set xlApp = Nothing
    Exit Sub
    
errHandler:
    MsgBox Err.Number & ". " & Err.Description
    Resume errExit
    Resume

Answer 3

Why am I getting Wend without While on this code?

        For i = 0 To .Fields.Count - 1
        xlWS.Cells(1, 1) = .Fields(i)
        Next

Hi InnVis,

The For i = 0 … loop needs an additional   Next   line.

Imb.

Answer 4

Thanks Imb! That got rid of the error, but now the report runs and nothing happens? I've never used the Wend function before. Here's what I did with it, thoughts?

Dim xlApp As Object
Dim xlWB As Object
Dim xlWS As Object
Dim db As DAO.Database
Dim rsEXHuddle As DAO.Recordset
Dim strSQL As String
Dim x As Long
Dim i As Integer

On Error GoTo errHandler
Set db = CurrentDb()
Set xlApp = CreateObject("Excel.Application")
Set xlWB = xlApp.Workbooks.Add

  If IsNull(txtshDate) Or Me.txtshDate.Value = "" Then
        MsgBox "NULL BOX", vbCritical, "REQUIRED FIELD"
        Else
        
        strSQL = "SELECT [CAP] AS CPCT , " _
        & " [DISCHARGES] AS DCHRGS , " _
        & " [EarlyDC] AS EDSG , " _
        & " [LateDC] AS LDC , " _
        & " [shEDDecisionToDepart] AS EDDTD , " _
        & " [shCVEarlyDCPrediction] AS CVEDCP , " _
        & " [shSurg_TranEarlyDCPrediction] AS STEDCP , " _
        & " [shPsych_RehabEarlyDCPrediction] AS PREDCP , " _
        & " [shMed_OncEarlyDCPrediction] AS MOEDCP , " _
        & " [WOCN] AS WNDCR , " _
        & " [shLateLabAssist] AS LABAST , " _
        & " [EVS_PM_STAFFING] AS EVSSTFNG , " _
        & " [shRTWalker] AS RTWLKR " _
        & " FROM qryServiceHuddleReport"
          
        End If
        
        Set rsEXHuddle = db.OpenRecordset(strSQL, dbOpenSnapshot)
        Set xlWS = xlWB.Sheets(1)

        xlWS.Cells(1, 1) = "CAPACITY %"
        xlWS.Cells(1, 2) = "TOTAL DISCHARGES #s"
        xlWS.Cells(1, 3) = "Before / <1pm"
        xlWS.Cells(1, 4) = "After/>5pm"
        xlWS.Cells(1, 5) = "ED Decision to Depart (minutes)"
        xlWS.Cells(1, 6) = "Card/Vasc"
        xlWS.Cells(1, 7) = "Surg/Trans"
        xlWS.Cells(1, 8) = "Psych/Rehab"
        xlWS.Cells(1, 9) = "Med/Onc"
        xlWS.Cells(1, 10) = "WOCN: Total; New; Unseen >24hrs"
        xlWS.Cells(1, 11) = "LAB: Nurse Draw Assists waiting >1hr as of 10:30"
        xlWS.Cells(1, 12) = "EVS pm staffing"
        xlWS.Cells(1, 13) = "RT Walkers"
        
       ' With rsEXHuddle
       ' xlWS.Cells(1, 1) = !DONTKNO
       ' End With
        
        'xlWS.Range(xlWS.Cells(1, 1), xlWS.Cells(1, 6)).Font.Bold = True
        'xlWS.Cells(1, 1) = "DATE"
        'xlWS.Cells(1, 2) = "UNIT"
        'xlWS.Cells(1, 3) = "AREA"
        'xlWS.Cells(1, 4) = "STANDARD REQUIREMENT"
        'xlWS.Cells(1, 5) = "NON-CONFORMITY DETAILS"
        'xlWS.Cells(1, 6) = "CORRECTIVE ACTION"
        'xlWS.Range(xlWS.Cells(1, 1), xlWS.Cells(1, 6)).Font.Bold = True
        
        'add data
        xlWS.Range("A2").CopyFromRecordset rsEXHuddle
        x = rsEXHuddle.RecordCount
        
        With rsEXHuddle
        While Not .EOF
        For i = 0 To .Fields.Count - 1
        Next
        xlWS.Cells(1, 1) = .Fields(i)
        .MoveNext
        Wend
        End With
        rsEXHuddle.Close
        

        'format
        xlWS.Range(xlWS.Cells(1, 1), xlWS.Cells(1, 6)).HorizontalAlignment = 3
        xlWS.Range(xlWS.Cells(2, 1), xlWS.Cells(x + 1, 2)).HorizontalAlignment = xlCenter
        xlWS.Range(xlWS.Cells(2, 3), xlWS.Cells(x + 1, 6)).HorizontalAlignment = xlLeft
        xlWS.Range(xlWS.Cells(1, 1), xlWS.Cells(x + 1, 13)).Borders.LineStyle = xlContinuous
        xlWS.Columns("A:M").AutoFit

'remove extra tabs
If xlWB.Sheets.Count > 1 Then
With xlWB
On Error Resume Next
    .Sheets("Sheet1").Delete
    .Sheets("Sheet2").Delete
    .Sheets("Sheet3").Delete
On Error GoTo 0
End With
Else
'xlWB.Close , False
xlApp.Visible = True
Exit Sub
End If

errExit:
    Set rsEXHuddle = Nothing
    Set db = Nothing
    Set xlWS = Nothing
    Set xlWB = Nothing
    Set xlApp = Nothing
    Exit Sub
    
errHandler:
    MsgBox Err.Number & ". " & Err.Description
    Resume errExit
    Resume

Answer 5

Imb - for a single loop, only one Next is required. Anything else is a syntax error.

---

peter n roth - http://PNR1.com, Maybe some useful stuff

Answer 6

I think you miss a Next before the .MoveNext.

---

Joao Simplicio Rodrigues

Answer 7

Imb - for a single loop, only one Next is required. Anything else is a syntax error.

Hi Peter,

I do not know what you mean with "a single loop".

As far as I know, you need a   Next   to go to the next   i   in the For-loop.

Then you need a   MoveNext   to go to the next record in the recordset.

I tested:

  While True

    For i = 1 To 10

        i = i

  Wend,

which gives the reported error message  Wend without While.

An extra   Next  to indicate the end of the statements in the For  loop, compiles OK.

Imb.

Answer 8

of course. There are too many different states of code being posted, so I'll step back until the dust settles.

---

peter n roth - http://PNR1.com, Maybe some useful stuff

Answer 9

Hey Peter, any idea why the error is fixed now, but nothing seems to be happening during the export process?

Answer 10

Assuming the latest posting above is the current state of code, and adding line numbers using MZTools, i find this curious construct 

270       With rsEXHuddle
280           While Not .EOF
290               For i = 0 To .Fields.Count - 1
300               Next
310               xlWS.Cells(1, 1) = .Fields(i)
320               .MoveNext
330           Wend
340       End With
350       rsEXHuddle.Close

What is this code supposed to do, and is it doing it? Looks like

xlWS.Cells(1,1) =.Fields(.Fields.Count-1) 

---

peter n roth - http://PNR1.com, Maybe some useful stuff

Answer 11

Again, I have no idea - I have never used the Wend function. This code was suggested to me in a previous forum post because it's supposed to turn the first picture above into the second picture (in other words shift the columns and rows appropriately). I'm assuming the Cells(1, 1) refers to the first cells that I want to start shifting and ends with the field record count? Not quite sure to be honest. All I'm trying to do is hopefully format my report to look like the second image posted.

Answer 12

Wend is not a Function, it is the closing part of a loop construct.

Three equivalent constructs are

While condition

    Execute this statement

Wend

=====

Do While condition

    Execute this statement

Loop

=====

Top: If condition then    
    Execute this statement    
    GoTo Top
End If

but the last one is "frowned on"

---

peter n roth - http://PNR1.com, Maybe some useful stuff

Answer 13

I guess that's why I'm having a hard time understanding. I thought Wend was used to transpose the record instead of colums being the field names and rows being the record into the reverse. Sort of like transposing in Excel.

Answer 14

A suggestion:

Where you got the code? Go there, and ask the code provider what it’s doing.

---

peter n roth - http://PNR1.com, Maybe some useful stuff

Answer 15

Ah yes, of course - why didn't I think of that! Asking the forum for help on the answer the forum suggested...wait I think I just fell into an infinite loop.

Answer 16

You'll need a Wend to get out of it

---

peter n roth - http://PNR1.com, Maybe some useful stuff

Answer 17

Hi InnVis,

This code...

While Not .EOF

End With
        

VBA decides to go on a rampage mode. Whether ".EOF = True" or ".EOF = False". I guess it decided to commit suicide. It does not know the condition to choose.

Here what I suggest.

'add data
'xlWS.Range("A2").CopyFromRecordset rsEXHuddle
'x = rsEXHuddle.RecordCount

        x = 2   'position insert point at Row (second row)
        y = 2   'position insert point at Column (second column)
        
With rsEXHuddle
    Do Until .EOF
        For i = 0 To .Fields.Count - 1
        xlWS.Cells(x, y) = .Fields(i)
        y = y + 1   'increment Column
        Next
        x = x + 1   'increment Row
        y = 2       'Reset Column
        .MoveNext
    Loop
End With
        rsEXHuddle.Close

Below is what I use from your code sample.

Option Compare Database
Option Explicit

Private Const xlTop = -4160
Private Const xlLeft = -4131
Private Const xlRight = -4152
Private Const xlCenter = -4108
Private Const xlEdgeTop = 8
Private Const xlEdgeLeft = 7
Private Const xlEdgeRight = 10
Private Const xlInsideVertical = 11
Private Const xlEdgeBottom = 9
Private Const xlInsideHorizontal = 12
Private Const xlUp = -4162
Private Const xlLandscape = 2
Private Const xlPaperA4 = 9
Private Const xlAutomatic = -4105
Private Const xlOverThenDown = 2
Private Const xlPrintErrorsDisplayed = 0
Private Const xlContinuous = 1
Private Const xlThin = 2

Sub ExcelTest()
On Error GoTo errHandler
Dim xlApp As Object
Dim xlWB As Object
Dim xlWS As Object
Dim db As DAO.Database
Dim rsEXHuddle As DAO.Recordset
Dim strSQL As String
Dim x As Long, y As Long
Dim i As Integer

On Error GoTo errHandler
Set db = CurrentDb()
Set xlApp = CreateObject("Excel.Application")
Set xlWB = xlApp.Workbooks.Add
xlApp.Visible = True
  If IsNull(txtshDate) Or Me.txtshDate.Value = "" Then
        'MsgBox "NULL BOX", vbCritical, "REQUIRED FIELD"
        Else
        
        strSQL = "SELECT [CAP] AS CPCT , " _
        & " [DISCHARGES] AS DCHRGS , " _
        & " [EarlyDC] AS EDSG , " _
        & " [LateDC] AS LDC , " _
        & " [shEDDecisionToDepart] AS EDDTD , " _
        & " [shCVEarlyDCPrediction] AS CVEDCP , " _
        & " [shSurg_TranEarlyDCPrediction] AS STEDCP , " _
        & " [shPsych_RehabEarlyDCPrediction] AS PREDCP , " _
        & " [shMed_OncEarlyDCPrediction] AS MOEDCP , " _
        & " [WOCN] AS WNDCR , " _
        & " [shLateLabAssist] AS LABAST , " _
        & " [EVS_PM_STAFFING] AS EVSSTFNG , " _
        & " [shRTWalker] AS RTWLKR " _
        & " FROM qryServiceHuddleReport"
          
        End If
        
        Set rsEXHuddle = db.OpenRecordset(strSQL, dbOpenSnapshot)
        Set xlWS = xlWB.Sheets(1)

        xlWS.Cells(2, 1) = "CAPACITY %"
        xlWS.Cells(3, 1) = "TOTAL DISCHARGES #s"
        xlWS.Cells(4, 1) = "Before / <1pm"
        xlWS.Cells(5, 1) = "After/>5pm"
        xlWS.Cells(6, 1) = "ED Decision to Depart (minutes)"
        xlWS.Cells(7, 1) = "Card/Vasc"
        xlWS.Cells(8, 1) = "Surg/Trans"
        xlWS.Cells(9, 1) = "Psych/Rehab"
        xlWS.Cells(10, 1) = "Med/Onc"
        xlWS.Cells(11, 1) = "WOCN: Total; New; Unseen >24hrs"
        xlWS.Cells(12, 1) = "LAB: Nurse Draw Assists waiting >1hr as of 10:30"
        xlWS.Cells(13, 1) = "EVS pm staffing"
        xlWS.Cells(14, 1) = "RT Walkers"
        
        'With rsEXHuddle
        xlWS.Cells(1, 1) = Now
        'End With
        
        'xlWS.Range(xlWS.Cells(1, 1), xlWS.Cells(1, 6)).Font.Bold = True
        'xlWS.Cells(2, 1) = "DATE"
        'xlWS.Cells(2, 2) = "UNIT"
        'xlWS.Cells(2, 3) = "AREA"
        'xlWS.Cells(2, 4) = "STANDARD REQUIREMENT"
        'xlWS.Cells(2, 5) = "NON-CONFORMITY DETAILS"
        'xlWS.Cells(2, 6) = "CORRECTIVE ACTION"
        'xlWS.Range(xlWS.Cells(1, 1), xlWS.Cells(1, 6)).Font.Bold = True
        
'-------not useful code------------------------------
        'add data
        'xlWS.Range("A2").CopyFromRecordset rsEXHuddle
        'x = rsEXHuddle.RecordCount
'----------------------------------------------------
        x = 2   'position insert point at Row (second row)
        y = 2   'position insert point at Column (second column)
        With rsEXHuddle
        Do Until .EOF
        For i = 0 To .Fields.Count - 1
        xlWS.Cells(x, y) = .Fields(i)
        y = y + 1   'increment Column
        Next
        x = x + 1   'increment Row
        y = 2       'Reset Column
        .MoveNext
        Loop
        End With
        rsEXHuddle.Close
        

        'format
        xlWS.Range(xlWS.Cells(1, 1), xlWS.Cells(1, 6)).HorizontalAlignment = 3
        xlWS.Range(xlWS.Cells(2, 1), xlWS.Cells(x + 1, 2)).HorizontalAlignment = xlCenter
        xlWS.Range(xlWS.Cells(2, 3), xlWS.Cells(x + 1, 6)).HorizontalAlignment = xlLeft
        xlWS.Range(xlWS.Cells(1, 1), xlWS.Cells(x + 1, 13)).Borders.LineStyle = xlContinuous
        'xlWS.Columns("A:M").Columns.AutoFit
        xlWS.Cells(2, 1).ColumnWidth = 10
        xlWS.Range(xlWS.Cells(2, 1), xlWS.Cells(14, 1)).WrapText = True
        xlWS.Cells(2, 1).WrapText = True

'remove extra tabs
'------you are deleting Sheet1??????------
'----comment out - not useful-------------
'If xlWB.Sheets.Count > 1 Then
'With xlWB
'On Error Resume Next
'    .Sheets("Sheet1").Delete
'    .Sheets("Sheet2").Delete
'    .Sheets("Sheet3").Delete
'On Error GoTo 0
'End With
'Else
''xlWB.Close , False
'xlApp.Visible = True  'move to errExit instead
'Exit Sub
'End If
'-----------------------------------------

errExit:
    On Error Resume Next    'avoid error loop
    xlApp.Visible = True    'Show Excel
    Set rsEXHuddle = Nothing
    Set db = Nothing
    Set xlWS = Nothing
    Set xlWB = Nothing
    Set xlApp = Nothing
    Exit Sub
    
errHandler:
    MsgBox Err.Number & ". " & Err.Description
    Resume errExit
    'Resume --- commented out, no idea what it does
End Sub

Answer 18

The code is gone ... (?)

Answer 19

Hey Vandal, the code you provided is a great start. However, it's not converting the data into columns to match the first column. Any thoughts?

Answer 20

Hi InnVis,

Not sure what you meant by "not converting the data". Perhaps if you could put a image to the results.

Answer 21

Of course, I apologize. Here's what I'm getting:

The items in column B should be the data represented for "Capacity" in B, C, D, etc. The items in column C is for Discharges... etc.

Answer 22

Hi InnVis,

So, your data is a Columnar from the SQL String? By default we normally assumed it is row by row.

You just change the X,Y like this...

        x = 2   'position insert point at Row (second row)
        y = 2   'position insert point at Column (second column)
        With rsEXHuddle
        Do Until .EOF
        For i = 0 To .Fields.Count - 1
        xlWS.Cells(x, y) = .Fields(i)
        x = x + 1   'increment Row
        Next
        y = y + 1   'increment Colmun
        x = 2       'Reset Row
        .MoveNext
        Loop
        End With
        rsEXHuddle.Close

As for the starting point, you need to find out yourself where would the Cell on Excel starts from.

You need to ask yourself where is the Cell position.

I'm just guessing it's at B2. If the starting point is at F2, Change X,Y starting point. Y=6 (F2 in Excel), X remain as second row (2).

        x = 2   'position insert point at Row (second row)
        y = 6   'position insert point at Column (second column)
        With rsEXHuddle
        Do Until .EOF
        For i = 0 To .Fields.Count - 1
        xlWS.Cells(x, y) = .Fields(i)
        x = x + 1   'increment Row
        Next
        y = y + 1   'increment Colmun
        x = 2       'Reset Row
        .MoveNext
        Loop
        End With
        rsEXHuddle.Close

Answer 23

Yes! This is an incredible start, thank you. I think I'm starting to understand this flip a bit more. Man I've been stuck on this for weeks now.