# VBA Procedure Won't Complete



## AlexB123 (Dec 27, 2022)

Hi all,

I received a file that I need to reformat to upload to a database. The current file is setup where one row represents one client, with twelve values for financial projections for each month of next year. I need this formatted with the same attributes, except i need one row for each monthly projection. I set up this procedure to copy Columns A through J, then to to copy the month/yr combo (eg -- 202301 for January) into column K, and then the value for that month in column L.  So I have 1248 rows, and I would expect this program to easily create 14,976.

But my program only successfully completes about 50 inner loops before getting hung up. I tried to leave my computer running, but it just froze. I am not sure if there is a memory leak somewhere, or if this is just an inefficient procedure. Are there some simple changes I can make to get this to finish?

Any input is appreciated!

Below is an example of part of the table ... I want to repeat the strings in State, County and Market, then copy the 2023XY label, then copy the value that was under the 2023XY Column to the cell beside the new paste.


StateCountyMarket202301202302NCBuncombeAsheville500.00250.00

Here is what I want it to look like:

StateCountyMarketMonth_YR_NumBudgetNCBuncombeAsheville202301500.00NCBuncombeAsheville202302250.00


```
Public Sub Auto_Budget_Prep_1()
'Macro to assist in preparing 2023 Budget for upload


'Error Handling
On Error GoTo 0


    'Declare Variables
    Dim macroWB As Workbook
    Dim srcWS1 As Worksheet
    Dim srcWS2 As Worksheet
               
    'Turn off notifications
    With Application
        .ScreenUpdating = False
'                .ScreenUpdating = True  --using comments to test this portion and see if the code was running
               
        .DisplayAlerts = False
    End With
   
    'Bind Objects
        Set macroWB = ThisWorkbook
            Set srcWS1 = macroWB.Worksheets("stage")
            Set srcWS2 = macroWB.Worksheets("budget")

                'COPY EACH ROW B:F 12 TIMES --- 1X FOR EACH Month
               

            'Find last row of each destination / summary file worksheet
            Dim NumRows As Long: NumRows = srcWS1.Range("A1", srcWS1.Range("A1").End(xlDown)).Rows.Count
     
            'need to create a month_yr_num stamp
            'Dim month7 As String: month7 = "202301"
            'Dim month8 As String: month8 = "202302"
            'Dim month9 As String: month9 = "202303"
            'Dim month10 As String: month10 = "202304"
            'Dim month11 As String: month11 = "202305"
            'Dim month12 As String: month12 = "202306"
            'Dim month13 As String: month13 = "202307"
            'Dim month14 As String: month14 = "202308"
            'Dim month15 As String: month15 = "202309"
            'Dim month16 As String: month16 = "202310"
            'Dim month17 As String: month17 = "202311"
            'Dim month18 As String: month18 = "202312"
     
     
           
            Dim i, j As Integer
            'declare k for row counter on srcsheet2
            'this variable is used to count rows for budget sheet ws2, it is not to be destroyed by loop
            j = 2
           
                'loop through each row stage sheet
                For i = 2 To 20
                 'For i = 2 To NumRows
                   
                    'this variable to be used for 12 columns / months
                    Dim k As Integer
                   
                        'inner loop will run once for each month of year
                        For k = 11 To 22
                        'first copy B:F to budget sheet
                        srcWS1.Range("A" & i & ":J" & i).Copy
                        srcWS2.Range("A" & j & ":J" & j).PasteSpecial xlPasteValues
                       
                        'now copy month_yr_num stamp col 11
                        srcWS1.Cells(1, k).Copy
                        srcWS2.Cells(j, 11).PasteSpecial xlPasteValues
                       
                        'now copy political budget value col 12
                        srcWS1.Cells(i, k).Copy
                        srcWS2.Cells(j, 12).PasteSpecial xlPasteValues
                       
                        'increment j
                        j = j + 1

                        'increment k
                        Next k
               
                'increment i
                Next i
      
      
        'Close out variables
        'Set j = Nothing
        'Set i = Nothing
        'Set NumRows = Nothing
        Set srcWS1 = Nothing
        Set srcWS2 = Nothing
        Set macroWB = Nothing

'Turn on notifications
    With Application
        .ScreenUpdating = True
        .DisplayAlerts = True
    End With

'Message
MsgBox "Done!"

End Sub
```


----------



## JGordon11 (Dec 27, 2022)

in Power Query


```
let
    Source = Excel.CurrentWorkbook(){[Name="Table1"]}[Content],
    Result = Table.UnpivotOtherColumns(Source, {"State", "County", "Market"}, "Month_YR_Num", "Budget")
in
    Result
```

Book1ABCDEFGHIJKL1StateCountyMarket202301202302StateCountyMarketMonth_YR_NumBudget2NCBuncombeAsheville500250NCBuncombeAsheville2023015003NCBuncombeAsheville20230225045Sheet2


----------



## HaHoBe (Dec 27, 2022)

Hi AlexB123,

you might need to adapt the column letters as you have shown data without information about the columns:

MrE_1225491_1616912_vba procedure wont_221227.xlsmABCDEFGHIJKLMNO1StateCountyMarket2023012023022023032023042023052023062023072023082023092023102023112023122NCBuncombeAsheville645,00620,00215,00262,00378,00638,00361,00488,00306,00720,00203,00593,003CASan BernadinoFort Irwin357,00540,00738,00353,00693,00630,00741,00485,00661,00712,00628,00656,00stage

MrE_1225491_1616912_vba procedure wont_221227.xlsmABCDE1StateCountyMarketMonth_YR_NumBudget2NCBuncombeAsheville202301645,003NCBuncombeAsheville202302620,004NCBuncombeAsheville202303215,005NCBuncombeAsheville202304262,006NCBuncombeAsheville202305378,007NCBuncombeAsheville202306638,008NCBuncombeAsheville202307361,009NCBuncombeAsheville202308488,0010NCBuncombeAsheville202309306,0011NCBuncombeAsheville202310720,0012NCBuncombeAsheville202311203,0013NCBuncombeAsheville202312593,0014CASan BernadinoFort Irwin202301357,0015CASan BernadinoFort Irwin202302540,0016CASan BernadinoFort Irwin202303738,0017CASan BernadinoFort Irwin202304353,0018CASan BernadinoFort Irwin202305693,0019CASan BernadinoFort Irwin202306630,0020CASan BernadinoFort Irwin202307741,0021CASan BernadinoFort Irwin202308485,0022CASan BernadinoFort Irwin202309661,0023CASan BernadinoFort Irwin202310712,0024CASan BernadinoFort Irwin202311628,0025CASan BernadinoFort Irwin202312656,00budget


```
Public Sub MrE_1225491_1616912()
' https://www.mrexcel.com/board/threads/vba-procedure-wont-complete.1225491/

'Macro to assist in preparing 2023 Budget for upload

'Declare Variables
Dim wsStage As Worksheet
Dim wsBudg As Worksheet
Dim NumRows As Long
Dim lngCounter As Long

'Turn off notifications
With Application
  .ScreenUpdating = False
  .DisplayAlerts = False
End With

'Error Handling
On Error GoTo 0

'Bind Objects
Set wsStage = ThisWorkbook.Worksheets("stage")
Set wsBudg = ThisWorkbook.Worksheets("budget")

With wsBudg
  .UsedRange.ClearContents
  .Range("A1").Resize(1, 5).Value = Array("State", "County", "Market", "Month_YR_Num", "Budget")
End With

'loop through each row stage sheet
For lngCounter = 2 To wsStage.Range("A" & wsStage.Rows.Count).End(xlUp).Row
  With wsBudg.Range("A" & wsBudg.Cells(wsBudg.Rows.Count, 1).End(xlUp).Offset(1, 0).Row)
    .Resize(12, 1).Value = wsStage.Cells(lngCounter, "A").Value
    .Offset(0, 1).Resize(12, 1).Value = wsStage.Cells(lngCounter, "B").Value
    .Offset(0, 2).Resize(12, 1).Value = wsStage.Cells(lngCounter, "C").Value
    .Offset(0, 3).Resize(12, 1).Value = WorksheetFunction.Transpose(wsStage.Cells(1, "D").Resize(1, 12).Value)
    With .Offset(0, 4).Resize(12, 1)
      .Value = WorksheetFunction.Transpose(wsStage.Cells(lngCounter, "D").Resize(1, 12).Value)
      .NumberFormat = "#,##0.00"
    End With
  End With
Next lngCounter

'Close out variables
Set wsStage = Nothing
Set wsBudg = Nothing

'Turn on notifications
With Application
  .ScreenUpdating = True
  .DisplayAlerts = True
End With

'Message
MsgBox "Done!"
End Sub
```

Ciao,
Holger


----------



## offthelip (Dec 27, 2022)

Another alterantive:

```
Sub test()
Dim outarr()
Lastcol = 15 ' I assume the last month is in column O (15)
With Worksheets("stage")
lastrow = .Cells(Rows.Count, "A").End(xlUp).Row
inarr = .Range(.Cells(1, 1), .Cells(lastrow, Lastcol))
End With
ReDim outarr(1 To lastrow * 12, 1 To 5)
indi = 1
For i = 2 To lastrow
 For k = 4 To 15
    For j = 1 To 3
     outarr(indi, j) = inarr(i, j)
    Next j
    outarr(indi, 5) = inarr(i, k)
    indi = indi + 1
 Next k
Next i
With Worksheets("budget")
 .Range(.Cells(1, 1), .Cells(lastrow * 12, 5)) = outarr
End With
End Sub
```
This uses varaint arrays so will be super fast


----------



## DanteAmor (Dec 27, 2022)

Here another macro for you to consider:

The data in the "stage" sheet begins and in cell A1. Results in cell A2 on sheet "budget"


```
Sub Auto_Budget_Prep_2()
  Dim sh1 As Worksheet, sh2 As Worksheet
  Dim a As Variant, b As Variant
  Dim i As Long, j As Long, k As Long, m As Long
  
  Set sh1 = Sheets("stage")     'source
  Set sh2 = Sheets("budget")    'destination
  
  a = sh1.Range("A1:V" & sh1.Range("A" & Rows.Count).End(3).Row).Value
  ReDim b(1 To UBound(a, 1) * 12, 1 To 12)
  
  For i = 2 To UBound(a, 1)
    For j = 11 To 22
      m = m + 1
      For k = 1 To 10
        b(m, k) = a(i, k)
      Next
      b(m, 11) = a(1, j)    'YearMonth
      b(m, 12) = a(i, j)    'Budget
    Next
  Next
  
  Sheets("budget").Range("A2").Resize(UBound(b, 1), UBound(b, 2)).Value = b
End Sub
```


----------

