I have downloaded the USA Gross Domestic Product, but this is originally by trimester and I need it my month, thus, I want to divide each cell of GDP / 3 to make my time series longer and be able to plot it by month: I want to create a loop in VBA to divide each value of GDP list 3 times, and then put it below each new value calculated:
Sub PIB()
Set lista = Range("D13:D275")
For Each cell In lista
For i = 1 To 3
Range("E13").Offset(i - 1, 0).Value = cell.Value / 3
Next i
Next cell
End Sub
Nonetheless, when I run it, it divides properly but just over the 3 first cells:
I want to effectively divide each cell 3 times and put it each value below each other, how I can do it?
Is this what you are trying:
Sub PIB()
Dim arr As Variant: arr = Range("D13:D275").Value
Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
Dim x As Long
For x = LBound(arr) To UBound(arr)
For i = 1 To 3
dict.Add Join(Array(arr(x, 1), x, i), "|"), arr(x, 1) / 3
Next i
Next
Range("E13").Resize(dict.Count).Value = Application.Transpose(dict.Items)
End Sub
Be aware of the non-explicit Range references.
If you need to split each value on three rows, please use the next code:
Sub SplitOnThreeMonths()
Dim sh As Worksheet, arr As Variant, arrFin As Variant, lastR As Long
Dim i As Long, j As Long, k As Long
Set sh = ActiveSheet
lastR = sh.Range("D" & Rows.count).End(xlUp).row
arr = sh.Range("D13:D" & lastR).Value
ReDim arrFin(1 To UBound(arr) * 3, 1 To 1)
k = 1
For i = 1 To UBound(arr)
For j = 1 To 3
arrFin(k, 1) = arr(i, 1) / 3: k = k + 1
Next j
Next i
sh.Range("E13").Resize(UBound(arrFin, 1), UBound(arrFin, 2)).Value = arrFin
End Sub
It will also allow the same Gross Domestic Product, even if happening that is not very probable. But, who knows?
I'm assuming you need to insert 2 rows to make space for the divided value three times -
however if you don't need to preserve data positions in the adjacent columns, the other answers provided using arrays are better than this one:
Sub PIB()
For i = 275 To 13 Step -1
Rows(i + 1 & ":" & i + 2).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Range(Cells(i, "E"), Cells(i + 2, "E")).Value2 = Cells(i, "D").Value2
Next i
End Sub
Please note I haven't qualified your ranges because I don't know what you want them to be, guessing it's the current sheet you're on.
Related
I have a WorksheetFunction.SumIfs with 3 Args code being applied in so many cells (10k rows x 20 columns), it ran for 2 hours to get complete, but when I do the same but with formula in excel and drag and drop until last column and line, it goes much faster (less than 10min).
I have already done xlCalculationManual. do you have any idea on how to improve processing time in VBA?
Code:
application.calculation= xlCalculationManual
for Col = 3 to 22
for Row = 2 to 10000
FileA.Cells(Row, Col).Value = Application.WorksheetFunction.SumIfs(FileB.Range("A:A"), FileB.Range("D:D"), FileA.Range("A" & Row).Value, FileB.Range("B:B"), FileA.Range("B" & Row).Value, FileB.Range("C:C"), FileA.Cells(1, Col).Value)
Next
Next
SOLUTION:
I found a simple solution by myself. In a big range of data, instead of using Application.WorksheetFunction.FUNCTION_NAME inside FOR, use Book.Sheet.Range().Formula = "=Formula(Parameters)" in the first Cell, then use .Copy, then .PasteSpecial Paste:=xlPasteFormulas, examples below:
' Takes 2h
for Col = 3 to 22
for Row = 2 to 10000
FileA.Cells(Row, Col).Value = Application.WorksheetFunction.SumIfs(FileB.Range("A:A"), FileB.Range("D:D"), FileA.Range("A" & Row).Value, FileB.Range("B:B"), FileA.Range("B" & Row).Value, FileB.Range("C:C"), FileA.Cells(1, Col).Value)
Next
Next
' Takes 10min
application.calculation= xlCalculationManual
FileA.Cells(2, 3).Formula = "=SUMIFS([FileB.XLSX]Sheet1!$A:$A,[FileB.XLSX]Sheet1!$D:$D,$A2,[FileB.XLSX]Sheet1!$B:$B,$B2,[FileB.XLSX]Sheet1!$C:$C,C$1)"
FileA.Cells(2, 3).Copy
FileA.Range(FileA.Cells(2, 3), FileA.Cells(10000, 22)).PasteSpecial Paste:=xlPasteFormulas
application.calculation= xlCalculationAutomatic
As per my comments, use variant arrays and loop the range once.
Sub mysumif()
Dim fileA As Worksheet
Set fileA = Worksheets("Sheet2")
Dim fileB As Worksheet
Set fileB = Worksheets("Sheet1")
Dim rngArr As Variant
rngArr = Intersect(fileB.Range("A:D"), fileB.UsedRange)
Dim Bclm As Variant
Bclm = Intersect(fileA.Range("A2:B100000"), fileA.UsedRange)
Dim ttlRos As Variant
ttlRos = Intersect(fileA.Range("C1:ZZ1"), fileA.UsedRange)
Dim otptArr As Variant
ReDim otptArr(1 To UBound(Bclm, 1), 1 To UBound(ttlRos, 2))
Dim i As Long
For i = 1 To UBound(rngArr, 1)
Dim j As Variant
j = Application.Match(rngArr(i, 3), ttlRos, 0)
If Not IsError(j) Then
Dim k As Long
For k = 1 To UBound(Bclm, 1)
If Bclm(k, 1) = rngArr(i, 4) And Bclm(k, 2) = rngArr(i, 2) Then
otptArr(k, j) = otptArr(k, j) + rngArr(i, 1)
Exit For
End If
Next k
End If
Next i
fileA.Range("C2").Resize(UBound(otptArr, 1), UBound(otptArr, 2)).Value = otptArr
End Sub
Before:
After:
Also note that a pivot table can do this also much quicker:
I have a table of hours against weeks (start of the week is a Sunday). The weekly data goes up to 12-16 months dependent on user input. I want to create a VBA macro which will iterate through this table of weekly hours data and convert the columns into monthly data.
Example:
All October 2021 related columns will collapse into 1 column called Oct-21. This will also combine the hours. 2nd row in the image below would equal 4+3+4+0= therefore value would be 11 in the new combined column's 2nd row.
My current thinking was calculating the Sundays between the start date and the last date which is below:
Dim d As Date, format As String, w As Long, FirstSunday As String
format = format(lastMonth, "Medium Date")
d = DateSerial(Year(format), Month(format), 1)
w = Weekday(d, vbSunday)
FirstSunday = d + IIf(w <> 1, 8 - w, 0)
Any ideas on how to do this?
Not sure how you want to group the weeks into months as some months will have 5 weeks. This code inserts a column when the month changes and then fills it with a sum formula for the relevant week columns. It assumes the dates are on row 1 , the task numbers in column 1 and the first week is in column 2.
Option Explicit
Sub ByMonth()
Dim wb As Workbook, ws As Worksheet
Dim LastCol As Long, LastRow As Long, c As Long, n As Long
Dim dt As Date
Set wb = ThisWorkbook
Set ws = wb.Sheets("Sheet1")
LastCol = ws.Cells(1, Columns.Count).End(xlToLeft).Column
LastRow = ws.Cells(Rows.Count, 1).End(xlUp).Row
' scan cols from right to left insert new columns
Application.ScreenUpdating = False
For c = LastCol + 1 To 3 Step -1
' add columns on month change
If Month(ws.Cells(1, c)) <> Month(ws.Cells(1, c - 1)) Then
ws.Columns(c).Insert
With ws.Columns(c)
.HorizontalAlignment = xlCenter
'.Interior.Color = RGB(255, 255, 200)
.Font.Bold = True
.Cells(1).NumberFormat = "#"
End With
End If
Next
' scan left to right filling new cols with sum() formula
' hide weekly columns
LastCol = ws.Cells(1, Columns.Count).End(xlToLeft).Column
n = 0
For c = 2 To LastCol + 1
If ws.Cells(1, c) = "" Then
dt = ws.Cells(1, c - 1)
ws.Cells(1, c) = MonthName(Month(dt), True) & " " & Year(dt)
ws.Cells(2, c).Resize(LastRow - 1).FormulaR1C1 = "=SUM(RC[-" & n & "]:RC[-1])"
n = 0
Else
ws.Columns(c).EntireColumn.Hidden = True
n = n + 1
End If
Next
' copy visible month columns to sheet2
ws.Cells.SpecialCells(xlCellTypeVisible).Copy
With wb.Sheets("Sheet2")
.Activate
.Range("A1").PasteSpecial xlPasteValues
.Range("A1").Select
End With
' end
ws.Columns.Hidden = False
Application.ScreenUpdating = True
Application.CutCopyMode = False
MsgBox "Done"
End Sub
Please, try the next code. It assumes that in column A:A, starting from the 6th row, there are (not sorted) tasks. If they are sorted, the code will run without problem, too. It uses arrays and a dictionary and mostly working in memory, should be very fast for big ranges:
Sub SumWeeksMonths()
Dim sh As Worksheet, sh1 As Worksheet, lastR As Long, arrWk, arrMonths, arrTasks
Dim i As Long, k As Long, j As Long, El, arr, arrFin, dict As New Scripting.Dictionary
Set sh = ActiveSheet 'use there the sheet to be processed
Set sh1 = sh.Next 'use here the sheet where the processed result to be returned
lastR = sh.Range("A" & sh.rows.count).End(xlUp).row 'last row (in column A:A)
arrWk = sh.Range(sh.Range("B5"), sh.cells(5, sh.Columns.count).End(xlToLeft)).Value 'place the Week headers in a 2D array
ReDim arrMonths(UBound(arrWk, 2) - 1)'redim the 1D array to keep the unique munths, at a maximum size
For i = 1 To UBound(arrWk, 2) - 1 'create the array of (only) months:
If month(DateValue(arrWk(1, i))) <> month(DateValue(arrWk(1, i + 1))) Then
k = k + 1: arrMonths(k) = Format(DateValue(arrWk(1, i + 1)), "mmm-yyyy")
Else
arrMonths(k) = Format(DateValue(arrWk(1, i)), "mmm-yyyy")
End If
Next i
ReDim Preserve arrMonths(k) 'preserve only the existing Date elements
For Each El In sh.Range("A4:A" & lastR).Value
dict(El) = 1 'extract the unique tasks (only to count them for ReDim the necessary array)
Next El
'place all the range to be processed in an array (for faster iteration):
arr = sh.Range("A5", sh.cells(lastR, sh.cells(5, sh.Columns.count).End(xlToLeft).Column)).Value
ReDim arrFin(1 To UBound(dict.Keys) + 1, 1 To UBound(arrMonths) + 2) 'reDim the final array to keep processed data
ReDim arrTasks(UBound(arrMonths)) 'redim the array to temporarily keep the array of each task summ
dict.RemoveAll: k = 0 'clear the dictionary and reitinialize the K variable
For i = 2 To UBound(arr) 'iterate between the main array elements:
If Not dict.Exists(arr(i, 1)) Then 'if the Task key does not exist:
For Each El In arrMonths 'iterate between each month in arrMonths:
For j = 2 To UBound(arr, 2) 'iterate between all arr columns for the i row:
If month(DateValue(arr(1, j))) = month(El) Then 'if column months is a specific arrMonths column:
arrTasks(k) = arrTasks(k) + arr(i, j) 'sumarize everything in the arrTask each element
End If
Next j
k = k + 1 'increment k, for the next month
Next El
dict.Add arr(i, 1), arrTasks 'create the dictionary key with the tasks array as item
ReDim arrTasks(UBound(arrMonths)): k = 0 'reinitialize arrTasks and k variable
Else 'if dictionary (task) key exists:
For Each El In arrMonths
For j = 2 To UBound(arr, 2)
If month(DateValue(arr(1, j))) = month(El) Then
arrTasks(k) = dict(arr(i, 1))(k) + arr(i, j) 'add the sum to the allready existing elements
End If
Next j
k = k + 1
Next El
dict(arr(i, 1)) = arrTasks 'make the item the updaded array
ReDim arrTasks(UBound(arrMonths)): k = 0 'reinitialize arrTasks and k variable
End If
Next i
'place the processed values in final array (arrFin):
For i = 0 To UBound(arrMonths) 'firstly the headers:
arrFin(1, i + 2) = arrMonths(i)
Next i
'Extract the tasks value for each month and place in the final array appropriate columns:
For i = 0 To dict.count - 1 'iterate between the dictionary elements:
arrFin(i + 2, 1) = dict.Keys(i) 'place the task in the array first column, starting from the second row
For j = 0 To UBound(dict.items(i)) 'iterate between the dictionary item array elements
arrFin(i + 2, j + 2) = dict.items(i)(j) 'place the appropriate array elements in the final array (arrFin)
Next j
Next i
'drop the final array at once and make some formatting:
With sh1.Range("A1").Resize(UBound(arrFin), UBound(arrFin, 2))
.Value = arrFin
With .rows(1)
.Font.Bold = True
.Interior.ColorIndex = 20
.BorderAround 1
End With
.EntireColumn.AutoFit
.BorderAround 1
End With
sh1.Activate 'to see the processing result...
MsgBox "Ready..."
End Sub
Please, test it and send some feedback.
Background:
In trying to better understand dynamic multi-dimensional arrays, I am attempting to build one to capture unique values and count the occurrences of the unique values (something i should be able to verify pretty quickly with a countif).
In reading about trying to redim preserve a multidimensional array, I had read that you can only redim the last parameters, so I was attempting to set-up for 2 parameters, where the first is the unique value and the second is the count: arr(2,k). If my understanding is wrong, then that also is pretty significant.
The final output of the array I am throwing into column 3 (unique ID) and column 4 (# of occurrences).
Issue:
When adding values to the array, I am not able to collect all unique values. I have been able to collect 3 unique values, when there are 6 in the data, and the occurrences of each are staying at 1, e.g., not iterating.
Question:
I apologize that this is essentially 2 questions...
1) is my use of redim preserver arr(2,0 to k) appropriate syntax?
2) is there a glaring issue with my dynamic array generation which would explain why i'm not getting all unique values captured?
I could ask a third about why i can't get the occurrence count to work, but I am hopeful that if I understand the above issue I can hopefully struggle through this part.
What the data looks like:
All data is in Column A
cat
dog
mouse
cat
mouse
bear
frog
cat
moose
cat
dog
Code in Question:
Option Explicit
Private Sub unique_arr()
Dim arr As Variant, i As Long, lr As Long, k As Long
lr = Cells(Rows.Count, 1).End(xlUp).Row
ReDim arr(2, k)
For i = 1 To lr
If Application.IfError(Application.Match(Cells(i, 1).Value, arr, 0), 0) = 0 Then
ReDim Preserve arr(2, 0 To k)
arr(1, k) = Cells(i, 1).Value
arr(2, k) = 1
k = k + 1
Else
arr(2, Application.Match(Cells(i, 1), arr(1), 0)) = arr(2, Application.Match(Cells(i, 1), arr(1), 0)) + 1
End If
Next i
For i = LBound(arr) To UBound(arr)
Cells(i + 1, 3).Value = arr(1, i)
Cells(i + 1, 4).Value = arr(2, i)
Next i
End Sub
While you would be better off overall with a dictionary, there are a few things wrong with the If comparison.
If Application.IfError(Application.Match(Cells(i, 1).Value, arr, 0), 0) = 0 Then
VBA has its own IsError that returns True/False.
If IsError(Application.Match(Cells(i, 1).Value, arr, 0), 0)) Then
Additionally, arr is a 2-D array; in essence it has both rows and columns. The worksheet's Match can only work on a single column or a single row. You need to 'slice' off what you want with Index.
If Not IsError(Application.Match(Cells(i, 1).Value, application.index(arr, 1, 0), 0), 0)) Then
Finally, arr is defined as ReDim arr(2, k). This makes it arr(0 to 2, 0 to k) so there are three elements in the first rank (0, 1, 2), not 2. You never actually use the 0 in the first rank. It should be,
k = 1
ReDim arr(1 to 2, 1 to k)
Wind it all up and you end up with something like this.
Option Explicit
Private Sub unique_arr()
Dim i As Long, lr As Long, k As Long, arr As Variant, m As Variant
'assign values to some vars
lr = Cells(Rows.Count, 1).End(xlUp).Row
k = 1
ReDim arr(1 To 2, 1 To k)
'loop through cells, finding duplicates and counting
For i = 1 To lr
m = Application.Match(Cells(i, 1).Value, Application.Index(arr, 1, 0), 0)
If IsError(m) Then
ReDim Preserve arr(1 To 2, 1 To k)
arr(1, k) = Cells(i, 1).Value
arr(2, k) = 1
k = k + 1
Else
arr(2, m) = arr(2, m) + 1
End If
Next i
'loop through array's second rank
For i = LBound(arr, 2) To UBound(arr, 2)
Cells(i, 3).Value = arr(1, i)
Cells(i, 4).Value = arr(2, i)
Next i
End Sub
For something like this, I'd use a Dictionary, like so:
Sub ExtractUniqueCounts()
Dim ws As Worksheet
Dim rCell As Range
Dim hUnq As Object
Set ws = ActiveWorkbook.ActiveSheet
Set hUnq = CreateObject("Scripting.Dictionary") 'Create Dictionary object
'Loop through populated cells in column A
For Each rCell In ws.Range("A1", ws.Cells(ws.Rows.Count, "A").End(xlUp)).Cells
'Ignore blanks
If Len(rCell.Value) > 0 Then
'Check if this is a new, unique value that hasn't been added yet
If Not hUnq.Exists(rCell.Value) Then
'New unique value found, add to dictionary and set count to 1
hUnq(rCell.Value) = 1
Else
'Not a unique value, increase existing count
hUnq(rCell.Value) = hUnq(rCell.Value) + 1
End If
End If
Next rCell
'Check if there are any results
If hUnq.Count > 0 Then
'Results found
'Output the keys (unique values)
ws.Range("C1").Resize(hUnq.Count).Value = Application.Transpose(hUnq.keys)
'Output the values of the keys (the counts in this case)
ws.Range("D1").Resize(hUnq.Count).Value = Application.Transpose(hUnq.items)
Else
'No results, return error
MsgBox "No data"
End If
End Sub
I have a lot of rows of data in Excel, each one corresponds to a product. So for example, my first row is "Lady's Black Dress" and then it has in another cell, sizes separated by commas and also colours in one cell too.
Title Size Colour Price Before Price After
Ladies Dress S,M,L,XL,XXL Blue, Black, Red 19.99 29.99
Men's Trousers S,M,L,XL,XXL Brown, Yellow, Orange 39.99 59.99
hj
So what I need is a VBA that creates a unique row (SKU, essentially) for each product variaton, so my data then looks like this:
I did ask this question before but only for 2 columns, a kind soul provided this VBA which does work, but I need the other columns. I don't quite understand how to adapt this VBA and was changing the letter "B" to "E" but this doesn't seem to work.
Option Explicit
Sub sizeExpansion()
Dim i As Long, szs As Variant
With Worksheets("sheet1")
For i = .Cells(.Rows.Count, "B").End(xlUp).Row To 2 Step -1
szs = Split(.Cells(i, "B").Value2, ",")
If CBool(UBound(szs)) Then
.Cells(i, "A").Resize(UBound(szs), 1).EntireRow.Insert
.Cells(i, "A").Resize(UBound(szs) + 1, 1) = .Cells(UBound(szs) + i, "A").Value2
.Cells(i, "B").Resize(UBound(szs) + 1, 1) = Application.Transpose(szs)
End If
Next i
End With
End Sub
Try this modification with an additional split variant and some maths adjustment.
Option Explicit
Sub sizeAndColorExpansion()
Dim i As Long, s As Long, c As Long
Dim ttl As String, pb As Double, pa As Double
Dim szs As Variant, clr As Variant
With Worksheets("sheet1")
For i = .Cells(.Rows.Count, "E").End(xlUp).Row To 2 Step -1
ttl = .Cells(i, "A").Value2
pb = .Cells(i, "D").Value2
pa = .Cells(i, "E").Value2
szs = Split(.Cells(i, "B").Value2, ",")
clr = Split(.Cells(i, "C").Value2, ",")
If CBool(UBound(szs)) Or CBool(UBound(clr)) Then
.Cells(i, "A").Resize((UBound(szs) + 1) * (UBound(clr) + 1) - 1, 1).EntireRow.Insert
For s = 0 To UBound(szs)
For c = 0 To UBound(clr)
.Cells(i + (s * (UBound(clr) + 1)) + c, "A").Resize(1, 5) = _
Array(ttl, Trim(szs(s)), Trim(clr(c)), pb, pa)
Next c
Next s
End If
Next i
End With
End Sub
I have data that I need to split into individual points. My macro charts the data, as a scatter plot, with: Column A as the title of the chart, Column B as the X axis, and Columns C and D as the Y axis. What I need is for when the Product ID has more than 1 number listed to split the numbers out into their own rows and keep the columns B, C, and D the same for each row created form the original. So for row 167, I would want 3 rows (001,002,003) each with packaging, 200, and 100, in B, C, and D respectively. I am not sure where to begin. I tried to build a macro but, I immediately got tripped up when I tried to record a "Find" Formula to run on the data. Any help would be greatly appreciated.
Column A: 001, 002, 003 // Column B:packaging // Column C:200 // Column D:100
Sorry I couldn't post a screenshot of my data, the forum won't let me. If you have any questions please let me know, I will be sure to check in frequently.
Thanks in advance.
I worte this VERY quickly and without much care for efficiency, but this should do the trick:
Sub SplitUpVals()
Dim i As Long
Dim ValsToCopy As Range
Dim MaxRows As Long
Dim ValToSplit() As String
Dim CurrentVal As Variant
MaxRows = Range("A1").End(xlDown).Row
For i = 1 To 10000000
ValToSplit = Split(Cells(i, 1).Value, ",")
Set ValsToCopy = Range("B" & i & ":D" & i)
For Each CurrentVal In ValToSplit
CurrentVal = Trim(CurrentVal)
Cells(i, 1).Value = CurrentVal
Range("B" & i & ":D" & i).Value = ValsToCopy.Value
Cells(i + 1, 1).EntireRow.Insert
i = i + 1
MaxRows = MaxRows + 1
Next
Cells(i, 1).EntireRow.Delete
If i > MaxRows Then Exit For
Next i
End Sub
As a note, make sure there's no data in cells beneath your data as it might get deleted.
You will need to parse the data in column A. I would do this by splitting the string in to an array, and then iterate over the array items to add/insert additional rows where necessary.
Without seeing your worksheet, I would probably start with something like this, which will split your cell value from column A in to an array, and then you can iterate over the items in the array to manipulate the worksheet as needed.
Sub TestSplit()
Dim myString as String
Dim myArray() as String
Dim cell as Range
Dim i as Long
For each cell in Range("A2",Range("A2").End(xlDown))
myString = cell.Value
myArray = Split(myString, ",") '<-- converts the comma-delimited string in to an array
For i = lBound(myArray) to uBound(myArray)
If i >= 1 Then
'Add code to manipulate your worksheet, here
End If
Next
Next
End Sub
This is a better solution (now that I had more time :) ) - Hope this does the trick!
Sub SplitUpVals()
Dim AllVals As Variant
Dim ArrayIndex As Integer
Dim RowLooper As Integer
AllVals = Range("A1").CurrentRegion
Range("A1").CurrentRegion.Clear
RowLooper = 1
For ArrayIndex = 1 To UBound(AllVals, 1)
ValToSplit = Split(AllVals(ArrayIndex, 1), ",")
For Each CurrentVal In ValToSplit
CurrentVal = Trim(CurrentVal)
Cells(RowLooper, 1).Value = CurrentVal
Cells(RowLooper, 2).Value = AllVals(ArrayIndex, 2)
Cells(RowLooper, 3).Value = AllVals(ArrayIndex, 3)
Cells(RowLooper, 4).Value = AllVals(ArrayIndex, 4)
RowLooper = RowLooper + 1
Next
Next ArrayIndex
End Sub
Sub DivideData()
'This splits any codes combined into the same line, into their own separate lines with their own separate data
Dim a, b, txt As String, e, s, x As Long, n As Long, i As Long, ii As Long
With Range("a1").CurrentRegion
a = .Value
txt = Join$(Application.Transpose(.Columns(1).Value))
x = Len(txt) - Len(Replace(txt, ",", "")) + .Rows.Count
ReDim b(1 To x * 2, 1 To UBound(a, 2))
For i = 1 To UBound(a, 1)
For Each e In Split(a(i, 1), ",")
If e <> "" Then
For Each s In Split(e, "-")
n = n + 1
For ii = 1 To UBound(a, 2)
b(n, ii) = a(i, ii)
Next
b(n, 1) = s
Next
End If
Next
Next
With .Resize(n)
.Columns(1).NumberFormat = "#"
.Value = b
End With
End With
End Sub