How can I shorten this VBA code? Copying and pasting cells - vba

A lot of the below code is duplicated for each cell I'm pasting to a new worksheet.
As an educational exercise, can anyone show me how I might shorten it?
Sub RowForTracker()
Worksheets.Add(After:=Worksheets(1)).Name = "ForTracker"
Sheets("Summary").Range("C2").Copy
Sheets("ForTracker").Range("A1").PasteSpecial Paste:=xlPasteValues
Sheets("Summary").Range("C6").Copy
Sheets("ForTracker").Range("B1").PasteSpecial Paste:=xlPasteValues
Sheets("Summary").Range("C8").Copy
Sheets("ForTracker").Range("C1").PasteSpecial Paste:=xlPasteValues
Sheets("Summary").Range("C3").Copy
Sheets("ForTracker").Range("D1").PasteSpecial Paste:=xlPasteValues
Sheets("Summary").Range("H8").Copy
Sheets("ForTracker").Range("E1").PasteSpecial Paste:=xlPasteValues
Sheets("Summary").Range("H9").Copy
Sheets("ForTracker").Range("F1").PasteSpecial Paste:=xlPasteValues
Sheets("Summary").Range("C5").Copy
Sheets("ForTracker").Range("G1").PasteSpecial Paste:=xlPasteValues
End Sub

another additional examples how you can achieve CopyPaste
Sub test1()
Dim S As Worksheet: Set S = Sheets("Summary")
Dim T As Worksheet: Set T = Sheets("ForTracker")
With T
.[A1] = S.[C2]
.[B1] = S.[C6]
.[C1] = S.[C8]
.[D1] = S.[C3]
.[E1] = S.[H8]
.[F1] = S.[H9]
.[G1] = S.[C5]
End With
End Sub
variant using array
Sub test2()
Dim S As Worksheet: Set S = Sheets("Summary")
Dim T As Worksheet: Set T = Sheets("ForTracker")
Dim CopyPaste, x%
x = 0
With S
CopyPaste = Array(.[C2], .[C6], .[C8], .[C3], .[H8], .[H9], .[C5])
End With
For Each oCell In T.[A1:G1]
oCell.Value = CopyPaste(x): x = x + 1
Next
End Sub
variant using split string
Sub test3()
Dim S As Worksheet: Set S = Sheets("Summary")
Dim T As Worksheet: Set T = Sheets("ForTracker")
Dim CopyPaste$
With S
CopyPaste = .[C2] & "|" & .[C6] & "|" & .[C8] & "|" & .[C3] & "|" & .[H8] & "|" & .[H9] & "|" & .[C5]
End With
T.[A1:G1] = Split(CopyPaste, "|")
End Sub
variant using dictionary
Sub test4()
Dim S As Worksheet: Set S = Sheets("Summary")
Dim T As Worksheet: Set T = Sheets("ForTracker")
Dim CopyPaste As Object: Set CopyPaste = CreateObject("Scripting.Dictionary")
Dim oCell As Range, Key As Variant, x%
x = 1
For Each oCell In S.[C2,C6,C8,C3,H8,H9,C5]
CopyPaste.Add x, oCell.Value: x = x + 1
Next
x = 0
For Each Key In CopyPaste
T.[A1].Offset(, x).Value = CopyPaste(Key)
x = x + 1
Next
End Sub

Well, if you want to just simplify it, you can do this:
Sub Main()
Dim wsS As Worksheet
Dim wsT As Worksheet
Set wsS = Sheets("Summary")
Set wsT = Sheets("ForTracker")
wsT.Range("A1").Value = wsS.Range("C2").Value
wsT.Range("B1").Value = wsS.Range("C6").Value
wsT.Range("C1").Value = wsS.Range("C8").Value
wsT.Range("D1").Value = wsS.Range("C3").Value
wsT.Range("E1").Value = wsS.Range("H8").Value
wsT.Range("F1").Value = wsS.Range("H9").Value
wsT.Range("G1").Value = wsS.Range("C5").Value
End Sub
It may not be necessary this time, but as you said, you wished for an educational excersise, you could create a procedure just for copying cell values from one to another. It could look like this:
Sub CopyValue(CopyFrom As Range, PasteTo As Range)
PasteTo.Value = CopyFrom.Value
End Sub
And you would call it like this:
CopyValue wsS.Range("C2"), wsT.Range("A1")
Or alternativelly, if you wanted to be extra clear, like this:
CopyValue CopyFrom:=wsS.Range("C2"), PasteTo:=wsT.Range("A1")

One way
Dim target As Range, item As Range, i As Long
With Worksheets.Add(After:=Worksheets(1))
.Name = "ForTracker"
Set target = .Range("A1")
End With
For Each item In Sheets("summary").Range("C2,C6,C8,C3,H8,H9,C5")
target.Offset(0, i).value = item.value
i = i + 1
Next

Try this:
Sub RowForTracker()
Dim wksSummary As Worksheet
Dim wksForTracker As Worksheet
Worksheets.Add(After:=Worksheets(1)).Name = "ForTracker"
Set wksSummary = Sheets("Summary")
Set wksForTracker = Sheets("ForTracker")
With wksForTracker
.Range("A1").Value = wksSummary.Range("C2").Value
.Range("B1").Value = wksSummary.Range("C6").Value
.Range("C1").Value = wksSummary.Range("C8").Value
.Range("D1").Value = wksSummary.Range("C3").Value
.Range("E1").Value = wksSummary.Range("H8").Value
.Range("F1").Value = wksSummary.Range("H9").Value
.Range("G1").Value = wksSummary.Range("C5").Value
End With
End Sub

Related

vba lookup to lookup info in a spread sheet

enter image description hereHi im trying to make a lookup for myself but am having a bit of trouble,
Private Sub CommandButton3_Click()
Dim cell As Range
Dim iRow As Long
Dim ws As Worksheet
Set ws = Worksheets("Sheet1")
If WorksheetFunction.CountIf(Sheet1.Range("A:A"), Me.textbox_GRN1.Value) = 0
Then
MsgBox "This is and incorrect GRN"
Me.textbox_GRN1.Value = ""
Exit Sub
End If
Dim rng As Range
Set rng = ws.Range("A2")
With ws
Me.textbox_BAY1.Value = Application.WorksheetFunction.VLookup(rng,
ws.Range("B1:B65536").Value, 1, False)
Me.textbox_ROW1.Value = Application.WorksheetFunction.VLookup(rng, ws.Range("C1:C65536").Value, 1, False)
Me.textbox_COLOUM1.Value = Application.WorksheetFunction.VLookup(rng, ws.Range("D1:D65536").Value, 1, False)
Me.textbox_PALLET1.Value = Application.WorksheetFunction.VLookup(rng, ws.Range("E1:E65536").Value, 1, False)
End With
End Sub
Private Sub CommandButton3_Click()
Dim cell As Range, GRN
Dim iRow As Long
Dim ws As Worksheet
Set ws = Worksheets("Sheet1")
GRN = Me.textbox_GRN1.Value
If WorksheetFunction.CountIf(Sheet1.Range("A:A"), GRN) = 0 Then
MsgBox "This is an incorrect GRN"
'Me.textbox_GRN1.Value = "" 'Don't do this!
'It will annoy your users
Exit Sub
End If
Dim rng As Range
Set rng = ws.Range("A1").CurrentRegion 'assumes no blank rows/columns in data table
Me.textbox_BAY1.Value = Application.VLookup(GRN, rng, 2, False)
Me.textbox_ROW1.Value = Application.VLookup(GRN, rng, 3, False)
Me.textbox_COLOUM1.Value = Application.VLookup(GRN, rng, 4, False)
Me.textbox_PALLET1.Value = Application.VLookup(GRN, rng, 5, False)
End Sub
I would prefer something like this though:
Private Sub CommandButton3_Click()
Dim f As Range, GRN
Dim ws As Worksheet
Set ws = Worksheets("Sheet1")
GRN = Me.textbox_GRN1.Value
Set f = ws.Columns(1).Find(GRN, lookat:=xlWhole)
If f Is Nothing Then
MsgBox "This is an incorrect GRN"
'Me.textbox_GRN1.Value = "" 'Don't do this!
'It will annoy your users
'you should probably clear the other textboxes here though
Else
With f.EntireRow
Me.textbox_BAY1.Value = .Cells(2).Value
Me.textbox_ROW1.Value = .Cells(3).Value
Me.textbox_COLOUM1.Value = .Cells(4).Value
Me.textbox_PALLET1.Value = .Cells(5).Value
End With
End If
End Sub

Assign column to an array VBA

I have this code. DataSet is set as a variant.
DataSet = Selection.Value
Works fine but is there a way I can change it to just column A, specifically cells A2 to A502? Ive tried setting that as the range but it doesn't work. It also needs to ignore blank spaces because not all of the cells will have content. I am trying to eliminate the need to highlight the cells as the entries will only be in that specific range.
Try these 2 versions:
Option Explicit
Public Sub getNonemptyCol_ForLoop()
Dim dataSet As Variant, fullCol As Variant, i As Long, j As Long
Dim lrFull As Long, lrData As Long, colRng As Range
Set colRng = ThisWorkbook.Worksheets(1).Range("A2:A502")
fullCol = colRng
lrFull = UBound(fullCol)
lrData = lrFull - colRng.SpecialCells(xlCellTypeBlanks).Count
ReDim dataSet(1 To lrData, 1 To 1)
j = 1
For i = 1 To lrFull
If Len(fullCol(i, 1)) > 0 Then
dataSet(j, 1) = fullCol(i, 1)
j = j + 1
End If
Next
End Sub
Public Sub getNonemptyCol_CopyPaste() 'without using a For loop
Dim dataSet As Variant, ws As Worksheet
Application.ScreenUpdating = False
Set ws = ThisWorkbook.Worksheets(1)
With ws.UsedRange
ws.Activate
.Range("A2:A502").SpecialCells(xlCellTypeConstants).Copy
.Cells(1, (.Columns.Count + 1)).Activate
ActiveSheet.Paste
dataSet = ws.Columns(.Columns.Count + 1).SpecialCells(xlCellTypeConstants)
'dataSet now contains all non-blank values
ws.Columns(.Columns.Count + 1).EntireColumn.Delete
.Cells(1, 1).Activate
End With
Application.ScreenUpdating = True
End Sub
Assign with dynamic column.
Sub SetActiveColunmInArray()
Dim w As Worksheet
Dim vArray As Variant
Dim uCol As Long
Dim address As String
Set w = Plan1 'or Sheets("Plan1") or Sheets("your plan name")
w.Select
uCol = w.UsedRange.Columns.Count
address = w.Range(Cells(1, 1), Cells(1, uCol)).Cells.address
vArray = Range(address).Value2
End Sub

Subscript out of range (error 9) --- running debugger and going through code everything is fine

Basically, have this code which uses Vlookups and a match to find past order dates of a particular product. The sub fills text boxes in a userform with N/A if there are no past orders found in the sheet. Otherwise, finds the latest order and fills the information in the userform.
The program stops when this sub routine is called. Getting 'subscript out of range' (error 9), I run the debugger and go through the code and everything works the way it is supposed to. In both the N/A case and the case where there is past order info.
Sub PastOrderInfo()
Dim wks As Worksheet
Dim Date_Ordered As Variant
Dim PreviousDate As Variant
Dim Qty_Ordered As String
Dim Total_Cost As String
Dim Rng, RngCol As String
Dim Last_Row As Long
Dim i, NewRow As Integer
Set wks = Worksheets("Order Data")
With wks
Last_Row = .UsedRange.Rows(.UsedRange.Rows.count).Row
Rng = "A2:D" & Last_Row
RngCol = "A2:A" & Last_Row
For i = 2 To Last_Row
If i = 2 Then
On Error Resume Next
PreviousDate = Application.VLookup(CStr(ProdNum), .Range(Rng), 2, False)
On Error GoTo 0
If IsError(PreviousDate) Then
Me.TextBox4.Value = "N/A"
Me.TextBox5.Value = "N/A"
Me.TextBox6.Value = "N/A"
Exit Sub
End If
NewRow = Application.Match(CStr(ProdNum), .Range(RngCol), 0) + 2
Rng = "A" & NewRow & ":D" & Last_Row
RngCol = "A" & NewRow & ":A" & Last_Row
ElseIf i > 2 Then
On Error Resume Next
Date_Ordered = Application.VLookup(CStr(ProdNum), .Range(Rng), 2, False)
On Error GoTo 0
If IsError(Date_Ordered) Then
NewRow = NewRow - 1
Rng = "A" & NewRow & ":D" & Last_Row
Me.TextBox4.Value = CDate(PreviousDate)
Me.TextBox5.Value = Application.VLookup(CStr(ProdNum), .Range(Rng), 3, False)
Me.TextBox6.Value = Application.VLookup(CStr(ProdNum), .Range(Rng), 4, False)
Exit Sub
End If
NewRow = Application.Match(CStr(ProdNum), .Range(RngCol), 0) + NewRow
Rng = "A" & NewRow & ":D" & Last_Row
RngCol = "A" & NewRow & ":A" & Last_Row
If Date_Ordered > PreviousDate Then PreviousDate = Date_Ordered
End If
Next i
Me.TextBox4.Value = CDate(PreviousDate)
Me.TextBox5.Value = Application.VLookup(CStr(ProdNum), .Range(Rng), 3, False)
Me.TextBox6.Value = Application.VLookup(CStr(ProdNum), .Range(Rng), 4, False)
End With
End Sub
Here is the line which is the section of code which opens the userform, when I click to debug it highlights the ProDescription.Show line below the if .Range(cellselect)...:
Private Sub CommandButton1_Click()
Dim i, r, c As Integer
Dim wks As Worksheet
Dim cellselect As String
Set wks = Workbooks("Data Direct Orders2.xlsx").Worksheets("Direct Items")
With wks
If ProdNumberCmbBox.ListIndex = -1 Then
Unload Me
ErrorMsg.Show
End
Else
For r = 2 To 84
cellselect = "A" & r
If .Range(cellselect).Text = ProdNum Then
ProDescription.Show
Unload Me
End
End If
Next r
If c = 0 Then
Unload Me
ErrorMsg.Show
End
End If
End If
End With
End Sub
Here is the sub routine where the userform is initialized:
Private Sub UserForm_Initialize()
TextBox8.Value = ProdNum
Call PastOrderInfo
End Sub
Just figured it out.
The line:
Set wks = Worksheets("Order Data")
in
Sub PastOrderInfo()
Was the problem. Needed to specify the workbook, so after adding:
Set wks = Workbooks("VBA - Final Project.xlsm").Worksheets("Order Data")
It worked!

VBA search column for strings and copy row to new worksheet

Not really good at VBA here. Found and edited some code that I believe can help me.
I need this code to search 2 columns (L and M) for any string in those columns that ends with _LC _LR etc... Example: xxxxxxxx_LC .
If the cell ends with anything in the array, I need the row to be copied to a new sheet. Here is what I have:
Option Explicit
Sub Test()
Dim rngCell As Range
Dim lngLstRow As Long
Dim keywords() As String
Dim maxKeywords As Integer
maxKeywords = 6
ReDim keywords(1 To maxKeywords)
maxKeywords(1) = "_LC"
maxKeywords(2) = "_LR"
maxKeywords(3) = "_LF"
maxKeywords(4) = "_W"
maxKeywords(5) = "_R"
maxKeywords(6) = "_RW"
lngLstRow = ActiveSheet.UsedRange.Rows.Count
For Each rngCell In Range("L2:L, M2:M" & lngLstRow)
For i = 1 To maxKeywords
If keywords(i) = rngCell.Value Then
rngCell.EntireRow.Copy
Sheets("sheet1").Select
Range("L65536, M65536").End(xlUp).Offset(1, 0).Select
Selection.PasteSpecial xlPasteValues
Sheets("Results").Select
End If
Next i
Next
End Sub
Okay, the issue I think is with your variable declarations. Before I continue, I will echo #GradeEhBacon's comment that if you can't read this and understand what's going on, you may want to take some time to learn VBA before running.
This should work, AFAIK. You didn't specify which sheet has what info, so that may have to be tweaked. Try the below, and let me know what is/isn't working:
Sub Test()
Dim rngCell As Range
Dim lngLstRow As Long
Dim keywords() As String, maxKeywords() As String
Dim totalKeywords As Integer, i&
Dim ws As Worksheet, resultsWS As Worksheet
Set ws = Sheets("Sheet1")
Set resultsWS = Sheets("Results")
totalKeywords = 6
ReDim keywords(1 To totalKeywords)
ReDim maxKeywords(1 To totalKeywords)
maxKeywords(1) = "_LC"
maxKeywords(2) = "_LR"
maxKeywords(3) = "_LF"
maxKeywords(4) = "_W"
maxKeywords(5) = "_R"
maxKeywords(6) = "_RW"
lngLstRow = ws.UsedRange.Rows.Count 'Assuming "Sheet1" is what you want to get the last range of.
Dim k& ' create a Long to use as Column numbers for the loop
For k = 12 To 13 ' 12 is column L, 13 is M
With ws 'I'm assuming your Ranges are on the "Sheet1" worksheet
For Each rngCell In .Range(.Cells(1, k), .Cells(lngLstRow, k))
For i = LBound(maxKeywords) To UBound(maxKeywords)
If maxKeywords(i) = Right(rngCell.Value, 3) or maxKeywords(i) = Right(rngCell.Value, 2) Then
' rngCell.EntireRow.Copy
' ws.Range("L65536, M65536").End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
resultsWS.Cells(65536, k).End(xlUp).Offset(1, 0).EntireRow.Value = rngCell.EntireRow.Value
End If
Next i
Next rngCell
End With
Next k
End Sub
This might be what you are looking for:
==================================================
Option Explicit
Sub Test()
Dim rngCell As Range
Dim lngLstRow As Long
Dim keywords() As String
Dim maxKeywords, i, j, k As Integer
maxKeywords = 6
ReDim keywords(1 To maxKeywords)
keywords(1) = "_LC"
keywords(2) = "_LR"
keywords(3) = "_LF"
keywords(4) = "_W"
keywords(5) = "_R"
keywords(6) = "_RW"
lngLstRow = ActiveSheet.UsedRange.Rows.Count
For j = 1 To lngLstRow
For i = 1 To maxKeywords
If keywords(i) = Right(Sheets("Results").Range("L" & j).Value, Len(keywords(i))) Or _
keywords(i) = Right(Sheets("Results").Range("M" & j).Value, Len(keywords(i))) Then
k = k + 1
Rows(j & ":" & j).Copy
Sheets("sheet1").Select
Range("A" & k).Select
ActiveSheet.Paste
End If
Next i
Next j
End Sub

VBA To Increment Sheets With The Same Name By 1

I currently have a spreadsheet that parses a HL7 message string using "|" as a delimiter. The String that comes before the first "|" becomes the sheet name (Segment). The code executes on each line of the string (Each segment is parsed). The problem is that sometimes there are multiple segments with the same name. So instead of a new sheet being created, all segments are lumped into the same sheet with that name. What I am trying to do is have the code create a new sheet for each segment and if there it is already present, add sheet name with an incremented number.
Sample Message:
MSH|^~\&|SR|500|CL|500|20140804150856-0500||SIU^S14|5009310|P|2.3|||AL|NE|USA
SCH|10262|10262|""|S14^(SCHEDULED)^L|44950^APPENDECTOMY^C4||^^^201408081345-0500^^^^^^2||30|MIN^MINUTES|^^^201408081345-0500^201408081415-0500|10000000034^ROISTAFF^CHIEF^O||||||||
PID|1|5000|50^^^USVHA&&0363^NI^FACILITY ID&500&L^^20140804~666^^^USSSA&&0363^SS^FACILITY ID&500&L~^^^USDOD&&0363^TIN^VA FACILITY ID&500&L~^^^USDOD&&0363^FI^FACILITY ID&500&L~736^^^USVHA&&0363^PI^VA FACILITY ID&500&L|736|DATA^PATIENT^^^^^L||19540214|M|||123 main Street^^SW RS^FL^33332^USA^P^^~^^^^^^N|||||||4221^764|666|||||N||||||N||
PV1|1|I|||||||||||||||||||||||||||||||||||||500|
OBX|1|CE|^SPECIALTY^||^GENERAL||||||S|||||
OBX|2|CE|^PATIENT CLASS^||^INPATIENT^L||||||S|||||
DG1|1|I9|540.1|ABSCESS OF APPENDIX||P
DG1|2|I9||APPENDICITIS||PR
RGS|1|A|
AIS|1|A|44950^APPENDECTOMY^C4||||
AIP|1|A|1000^PHYSICIAN^KT^|^SURGEON^99||||PENDING
AIP|2|A|1000^NURSE^ONE^|^1ST ASST.^99||||PENDING
AIP|3|A|1000^NURSE^TWO^|^2ND ASST.^99||||PENDING
AIP|4|A|1000^ATTENDING^ONE^|^ATT. SURGEON^99||||PENDING
AIP|5|A|115^DATA^PROVIDERONE^|^PRIN. ANES.^99||||PENDING
AIP|6|A|1000^DATA^PATHOLOGIST^|^ANES. SUPER.^||||PENDING
AIL||500^^^OR1|^OPERATING ROOM||||PENDING
Option Explicit
Const HL7_DELIMITER_FIELD = "|"
Const HL7_DELIMITER_SEGMENT = vbLf
Sub DoHL7Parsing(sMessage As String)
Dim vSegments As Variant, vCurSeg As Variant
Dim vFields As Variant, rCurField As Range, iIter As Integer
Dim wsSeg As Worksheet
vSegments = VBA.Split(sMessage, HL7_DELIMITER_SEGMENT)
For Each vCurSeg In vSegments
vFields = VBA.Split(vCurSeg, HL7_DELIMITER_FIELD)
If WorksheetExists(vFields(0), ThisWorkbook) Then
On Error Resume Next
For iIter = 1 To UBound(vFields)
Set rCurField = ThisWorkbook.Worksheets(vFields(0)).Range("A65536").End(xlUp).Offset(1, 0)
rCurField.Value = vFields(0)
rCurField.Offset(0, 1).Value = (rCurField.Row - 1)
rCurField.Offset(0, 2).NumberFormat = "#"
rCurField.Offset(0, 2).Value = vFields(iIter)
Next iIter
On Error Resume Next
ElseIf Not WorksheetExists(vFields(0), ThisWorkbook) Then
Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = vFields(0)
For iIter = 1 To UBound(vFields)
Set rCurField = ThisWorkbook.Worksheets(vFields(0)).Range("A65536").End(xlUp).Offset(1, 0)
rCurField.Value = vFields(0)
rCurField.Offset(0, 1).Value = (rCurField.Row - 1)
rCurField.Offset(0, 2).NumberFormat = "#"
rCurField.Offset(0, 2).Value = vFields(iIter)
Next iIter
'MsgBox "Invalid or unkown segment: " & vFields(0)
End If
Next vCurSeg
On Error Resume Next
End Sub
Public Function WorksheetExists(ByVal WorksheetName As String, Optional InWorkbook As Workbook) As Boolean
Dim Sht As Worksheet
WorksheetExists = False
If Not InWorkbook Is Nothing Then
For Each Sht In InWorkbook.Worksheets
If Sht.Name = WorksheetName Then WorksheetExists = True
Next Sht
Else
For Each Sht In ActiveWorkbook.Worksheets
If Sht.Name = WorksheetName Then WorksheetExists = True
Next Sht
End If
On Error Resume Next
End Function
The trick here is to just count the number of sheets whose Left(ShtName,3) value is equal to vFields(0). Based on the count, add 1 and append to end of vField(0). With this approach, you don't even need the dirty On Error Resume Next because you won't be targeting the same sheet twice, which can bring down your line count considerably.
For the sheet counting, add the following function to your module:
Function CountSheetsWithName(ShtName As String) As Long
Dim WS As Worksheet, Res As Long
Res = 0
For Each WS In ThisWorkbook.Worksheets
If Left(WS.Name, 3) = ShtName Then
Res = Res + 1
End If
Next
CountSheetsWithName = Res
End Function
Update your DoHL7Parsing subroutine as follows:
Sub DoHL7Parsing(sMessage As String)
Dim vSegments As Variant, vCurSeg As Variant
Dim vFields As Variant, rCurField As Range, iIter As Integer
Dim wsSeg As Worksheet, sShtName As String
vSegments = VBA.Split(sMessage, HL7_DELIMITER_SEGMENT)
Application.ScreenUpdating = False
For Each vCurSeg In vSegments
vFields = VBA.Split(vCurSeg, HL7_DELIMITER_FIELD)
For iIter = 1 To UBound(vFields)
sShtName = vFields(0) & (CountSheetsWithName(CStr(vFields(0))) + 1) ' Append the count + 1 to end of name.
Sheets.Add(After:=Sheets(Sheets.Count)).Name = sShtName
Set rCurField = ThisWorkbook.Worksheets(sShtName).Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
rCurField.Value = vFields(0)
rCurField.Offset(0, 1).Value = (rCurField.Row - 1)
rCurField.Offset(0, 2).NumberFormat = "#"
rCurField.Offset(0, 2).Value = vFields(iIter)
Next iIter
Next vCurSeg
Application.ScreenUpdating = True
End Sub
Result:
Hope this helps.