As a non-professional but research for accelerate data entry in excel, I've designed an Excel userform with 'split row and columns' for each 'Actors' and 'Paxs' textboxes. With initial input, the entry was fine but when repeat, the information overwritten the recent ones. I've no knowledge to adjust such overwriting. Do I miss something there? advise,please.
Private Sub cmdIn_Click()
Dim RowCnt As Long
Dim Actors As Variant
Dim ColNum1 As Variant
Dim j As Integer
Dim Paxs As Variant
Dim ColNum2 As Variant
Dim k As Integer
Dim ws As Worksheet
Set ws = Worksheets("ActPaxs")
RowCnt = ws.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
RowCnt = 2
Actors = Split(Me.TxtActors.Value, vbCrLf)
For Each r In Actors
j = 1
ColNum1 = Split(r, ", ")
For Each c In ColNum1
ws.Cells(RowCnt, j).Value = c
j = j + 1
Next c
RowCnt = RowCnt + 1
Next r
RowCnt = 2
Paxs = Split(Me.TxtPaxs.Value, vbCrLf)
For Each p In Paxs
k = 4
ColNum2 = Split(p, ", ")
For Each q In ColNum2
ws.Cells(RowCnt, k).Value = q
k = k + 1
Next q
RowCnt = RowCnt + 1
Next p
TxtActors.Text = ""
TxtPaxs.Text = ""
End Sub
How to repeat same code to add more data and not overwrite the existing ones?
RowCnt = ws.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
RowCnt = 2
delete the second instance which hard codes to row 2, the first instance detects the last used row and offsets by 1
Edit: you have another instance of RowCnt = 2 further down in the code, delete that too.
Related
I want to remove predefined parts of the strings in the following table and save the values in an array. For some reason I get an error stating that I'm outside of the index. The lengths of the strings in the table can vary.
Sub New_1()
Dim i, j, k As Integer
Dim Endings As Variant
k = 0
Endings = Array("/A", "/BB", "/CCC", "/DDDD", "/EEEEE")
Dim ArrayValues() As Variant
With Worksheets("table1")
Dim lastRow As Long: lastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
ReDim ArrayValues(lastRow)
For i = lastRow To 1 Step -1
For j = 0 To UBound(Endings)
ArrayValues(k) = Replace(.Range("A" & i), Endings(j), "")
k = k + 1
Next j
Next i
End With
End Sub
You're getting out of bounds because your ArrValues is filled up after not even 3 iterations of your "i" since you're adding up your k every j iterations
If you want an array of the cleaned up cells do this instead:
Sub New_1()
Dim i As Integer, j As Integer, k As Integer
Dim Endings As Variant
Dim ArrayValues() As Variant
Dim lastRow As Long
Endings = Array("/A", "/BB", "/CCC", "/DDDD", "/EEEEE")
With Worksheets("Blad6")
lastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
ReDim ArrayValues(1 To lastRow) 'Then you don't have an empty ArrayValues(0)
For i = lastRow To 1 Step -1
For j = 0 To UBound(Endings)
If j = 0 Then
ArrayValues(i) = Replace(.Range("A" & i), Endings(j), "")
Else
ArrayValues(i) = Replace(ArrayValues(i), Endings(j), "")
End If
Next j
Next i
'Use Array here
End With
End Sub
If your intent is to create an array in which everything after the / is removed, this might be simpler, using the Split function; and also faster by storing the data to be split in a VBA array, in iterating through that array instead of the worksheet cells.
Option Explicit
Sub New_1()
'in VBA, Long is marginally more efficient than Integer
Dim k As Long, v As Variant
Dim dataArr As Variant
Dim ArrayValues() As Variant
With Worksheets("SHEET7")
'faster to loop through VBA array than worksheet cells
'Note that this will be a 2D array with dimensions starting at 1, not 0
dataArr = Range(.Cells(1, 1), .Cells(.Rows.Count, 1).End(xlUp))
End With
'This might be simpler
ReDim ArrayValues(1 To UBound(dataArr, 1))
k = 0
For Each v In dataArr
k = k + 1
ArrayValues(k) = Split(v, "/")(0)
Next v
End Sub
I'm having trouble with some VBA code and was hoping that someone could help me out.
The problem is with me referencing a specific cell. The code below copies rows into another worksheet and deletes them in the worksheet it took them from based on a value.
The issue is that I want the user to be able to specify the value in a specific cell rather than coming back to a spreadhseet to alter and realter it (it's just a quality of life thing).
Here's the code and what I mean:
Sub Kappa()
Dim xRg As Range
Dim xCell As Range
Dim I As Long
Dim J As Long
Dim K As Long
I = Worksheets("Data").UsedRange.Rows.Count
J = Worksheets("Archives").UsedRange.Rows.Count
If J = 1 Then
If Application.WorksheetFunction.CountA(Worksheets("Archives").UsedRange) = 0 Then J = 0
End If
Set xRg = Worksheets("Data").Range("I1:I" & I)
On Error Resume Next
Application.ScreenUpdating = False
For K = 1 To xRg.Count
If CStr(xRg(K).Value) = Application.Workbooks("Book1.xlsm").Worksheets("Data").Range("M5") Then
xRg(K).EntireRow.Copy Destination:=Worksheets("Archives").Range("A" & J + 1)
xRg(K).EntireRow.Delete
If CStr(xRg(K).Value) = Application.Workbooks("Book1.xlsm").Worksheets("Data").Range("M5") Then
K = K - 1
End If
J = J + 1
End If
Next
Application.ScreenUpdating = True End Sub
What happens with this is that it spins (I couldn't even get an error!).
If you alter the code to say something along the lines of:
Sub Kappa()
Dim xRg As Range
Dim xCell As Range
Dim I As Long
Dim J As Long
Dim K As Long
I = Worksheets("Data").UsedRange.Rows.Count
J = Worksheets("Archives").UsedRange.Rows.Count
If J = 1 Then
If Application.WorksheetFunction.CountA(Worksheets("Archives").UsedRange) = 0 Then J = 0
End If
Set xRg = Worksheets("Data").Range("I1:I" & I)
On Error Resume Next
Application.ScreenUpdating = False
For K = 1 To xRg.Count
If CStr(xRg(K).Value) = "Alpha" Then
xRg(K).EntireRow.Copy Destination:=Worksheets("Archives").Range("A" & J + 1)
xRg(K).EntireRow.Delete
If CStr(xRg(K).Value) = "Alpha" Then
K = K - 1
End If
J = J + 1
End If
Next
Application.ScreenUpdating = True End Sub
It works like a charm.
Is there any way of repurposing this so it references a value in a cell?
I have a bunch of word documents that each contain a single table, some of which hold an exorbitant amount of data (20,000+ rows perhaps) and hence can stretch over hundreds of pages long.
With that being said, I found a VBA word macro that can display all row indices that start every page. For example, the macro will display 100 integers for a table that stretches for 100 pages. This is exactly what I need but for various reasons, the macro runs very slow. Furthermore, it runs even slower when I adapted the code and embedded it into an excel macro (to use on a word object).
So my question is - can this macro be somehow optimized? I suppose the looping is causing the problem. Many thanks for your input!
Sub TableRowData()
'define meaningful names to use for array's first dimension
Const pgnum = 1
Const startrow = 2
Const endrow = 3
Dim data() As Long ' array to hold data
Dim rw As Row ' current row of table
Dim rownum As Long ' the index of rw in table's rows
Dim datarow As Long ' current value of array's second dimension
Dim rg As Range ' a range object for finding the page where rw starts
'initialization
ReDim data(3, 1)
Set rw = ActiveDocument.Tables(1).Rows(1)
rownum = 1
datarow = 1
'store the page number and row number for the first row of the table
Set rg = rw.Range
rg.Collapse wdCollapseStart
data(pgnum, datarow) = rg.Information(wdActiveEndAdjustedPageNumber)
data(startrow, datarow) = rownum
'Step through the remaining rows of the table.
'Each time the page number changes, store the preceding row as the
'last row on the previous page; then expand the array and store the
'page number and row number for the new row.
While rownum < ActiveDocument.Tables(1).Rows.Count
Set rw = rw.Next
rownum = rownum + 1
Set rg = rw.Range
rg.Collapse wdCollapseStart
If rg.Information(wdActiveEndAdjustedPageNumber) > data(pgnum, datarow) Then
data(endrow, datarow) = rownum - 1
ReDim Preserve data(3, datarow + 1)
datarow = datarow + 1
data(pgnum, datarow) = rg.Information(wdActiveEndAdjustedPageNumber)
data(startrow, datarow) = rownum
End If
Wend
'finish up with the last row of the table
data(endrow, datarow) = rownum
Dim msg As String
Dim i As Long
For i = 1 To UBound(data, 2)
msg = msg & data(startrow, i) & vbCr
Next i
MsgBox msg
End Sub
Try something based on:
Sub TableRowData()
Dim Doc As Document, Rng As Range, Data() As Long, i As Long, j As Long, p As Long, r As Long, x As Long
Set Doc = ActiveDocument
With Doc
With .Tables(1).Range
i = .Cells(1).Range.Characters.First.Information(wdActiveEndAdjustedPageNumber)
j = .Cells(.Cells.Count).Range.Characters.Last.Information(wdActiveEndAdjustedPageNumber)
ReDim Data(3, j - i)
For p = i To j
Set Rng = Doc.Range.GoTo(What:=wdGoToPage, Name:=p)
Set Rng = Rng.GoTo(What:=wdGoToBookmark, Name:="\page")
r = Rng.Cells(1).RowIndex
x = p - i: Data(1, x) = x: Data(2, x) = p: Data(3, x) = r
Next
End With
End With
End Sub
Processing tables row by row is notoriously slow and there is little you can do to speed things up.
One thing that will help is to turn off screen updating. At the start of your routine add Application.ScreenUpdating = False and at the end Application.ScreenUpdating = True.
The other thing you can experiment with is using a For Each loop. There is some disagreement as to whether or not this method is faster. Having a large table to process will give you a pretty good idea of which is the faster method, but don't expect miracles. Whichever method you adopt you are going to need patience.
Sub TableRowData()
Application.ScreenUpdating = False
'define meaningful names to use for array's first dimension
Const pgnum = 1
Const startrow = 2
Const endrow = 3
Dim data() As Long ' array to hold data
Dim rw As Row ' current row of table
Dim rownum As Long ' the index of rw in table's rows
Dim datarow As Long ' current value of array's second dimension
'Dim rg As Range ' a range object for finding the page where rw starts
'initialization
ReDim data(3, 1)
Set rw = ActiveDocument.Tables(1).Rows(1)
rownum = 1
datarow = 1
'store the page number and row number for the first row of the table
Set rg = rw.Range
rg.Collapse wdCollapseStart
data(pgnum, datarow) = rg.Information(wdActiveEndAdjustedPageNumber)
data(startrow, datarow) = rownum
'Step through the remaining rows of the table.
'Each time the page number changes, store the preceding row as the
'last row on the previous page; then expand the array and store the
'page number and row number for the new row.
'While rownum < ActiveDocument.Tables(1).Rows.Count
For Each rw In ActiveDocument.Tables(1).Rows
'Set rw = rw.Next
rownum = rownum + 1
'Set rg = rw.Range
'rg.Collapse wdCollapseStart
If rw.Range.Information(wdActiveEndAdjustedPageNumber) > data(pgnum, datarow) Then
data(endrow, datarow) = rownum - 1
ReDim Preserve data(3, datarow + 1)
datarow = datarow + 1
data(pgnum, datarow) = rw.Range.Information(wdActiveEndAdjustedPageNumber)
data(startrow, datarow) = rownum
End If
Next rw
'Wend
'finish up with the last row of the table
data(endrow, datarow) = rownum
Dim msg As String
Dim i As Long
For i = 1 To UBound(data, 2)
msg = msg & data(startrow, i) & vbCr
Next i
MsgBox msg
Application.ScreenUpdating = True
End Sub
How about looping through the pages and getting the row number?
Would that work?
Dim doc As Document
Dim rng As Range
Dim pg As Long
Application.ScreenUpdating = False
Set doc = ThisDocument
For pg = 1 To doc.Range.Information(wdNumberOfPagesInDocument)
Set rng = doc.GoTo(wdGoToPage, wdGoToAbsolute, pg)
Debug.Print rng.Information(wdEndOfRangeRowNumber)
Next pg
Sub adress()
Dim s As Long
Dim h As Long
Dim n As Long
Dim i As Long
s = 1
n = 1
h = 1
For n = 1 To 1800
For i = 1 To 2000
If ActiveSheet.Cells(h + 1, 13) = ActiveSheet.Cells(s + 1, 32) Then
ActiveSheet.Cells(h + 1, 48) = ActiveSheet.Cells(s + 1, 36)
ActiveSheet.Cells(h + 1, 51) = ActiveSheet.Cells(s + 1, 37)
End If
s = s + 1
Next i
h = h + 1
i = 1
Next n
End Sub
This code is written to grab a value in a column of an excel spread sheet, then go to the next column and search the whole column for a matching value. Once that is found it will print the value that is in a cell in the same row of the value in the second column it found, into a cell in the same row as the original value it was trying to match.
While the inner loop works and my code will do the correct process when ran, it only does it for one value in the first column. I have tried using ranges in the For Loops, I have tried do while loops and do until loops. If i manually change the value of "h" and run the code it will progress down the column and print the correct information but i cannot get "h" to update on its own.
Nested For Next Loops
Although Exit For and turning off the two application settings are used, the first procedure still takes 45 seconds on my machine (without the 'improvements' it might take half an hour).
In the second code the inner loop is replaced with Application.Match and the operations are performed using arrays. It takes less than a second.
The Code
Option Explicit
Sub loopSlow()
Dim i As Long
Dim k As Long
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
With ActiveSheet
For i = 2 To 1801
For k = 2 To 2001
If .Cells(i, 13).Value = .Cells(k, 32).Value Then
.Cells(i, 48).Value = .Cells(k, 36).Value
.Cells(i, 51).Value = .Cells(k, 37).Value
Exit For
End If
Next k
Next i
End With
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
Sub loopFast()
' Source
Const sName As String = "Sheet2"
Const sColsList As String = "AF,AJ,AK"
Const sFirstRow As Long = 2
' Destination (Lookup)
Const dName As String = "Sheet2"
Const dColsList As String = "M,AV,AY"
Const dFirstRow As Long = 2
' Define workbook.
Dim wb As Workbook: Set wb = ThisWorkbook
' Declare variables.
Dim ws As Worksheet
Dim rg As Range
Dim Cols() As String
Dim cUpper As Long
Dim cOffset As Long
Dim n As Long
' Write values from Source Columns to arrays of Data Array.
Cols = Split(sColsList, ",")
cUpper = UBound(Cols)
Set ws = wb.Worksheets(sName)
Set rg = ws.Cells(ws.Rows.Count, Cols(0)).End(xlUp)
Set rg = ws.Range(ws.Cells(sFirstRow, Cols(0)), rg)
Dim Data As Variant: ReDim Data(0 To cUpper)
For n = 0 To cUpper
cOffset = ws.Columns(Cols(n)).Column - rg.Column
Data(n) = rg.Offset(, cOffset).Value
Next n
' Write values from Lookup Column to Lookup Array of Result Array.
Cols = Split(dColsList, ",")
Set ws = wb.Worksheets(dName)
Set rg = ws.Cells(ws.Rows.Count, Cols(0)).End(xlUp)
Set rg = ws.Range(ws.Cells(dFirstRow, Cols(0)), rg)
Dim Result As Variant: ReDim Result(0 To cUpper)
Result(0) = rg.Value
' Define the (remaining) Write Arrays of Result Array.
Dim ResultNew As Variant: ReDim ResultNew(1 To UBound(Result(0)), 1 To 1)
For n = 1 To cUpper
Result(n) = ResultNew
Next n
' Write values from Data Array to Write Arrays of Result Array.
Dim cIndex As Variant
Dim i As Long
For i = 1 To UBound(Result(0))
cIndex = Application.Match(Result(0)(i, 1), Data(0), 0)
If IsNumeric(cIndex) Then
For n = 1 To cUpper
Result(n)(i, 1) = Data(n)(cIndex, 1)
Next n
End If
Next i
' Write values from Write Arrays of Result Array to Destination Columns.
For n = 1 To cUpper
cOffset = ws.Columns(Cols(n)).Column - rg.Column
rg.Offset(, cOffset).Value = Result(n)
Next n
End Sub
I am working on the code where I want to write 2 arrays (assigned in 'Input sheet) to 'Output' sheet n times, i.e. specifically 2 times in the loop. I want to use arrays because the range of the ids and its names can change (it can be much more).
To start with a simple example (with a small amount of data), the arrays are assigned acc. to data in 'Input' sheet:
These 2 arrays should be written to 'Output' sheet n times i.e.; They should be written once and then again in the loop i.e. 2 times. I want to do it in the loop to give it the flexibility of writing in the future e.g. 3, 4, n times. In this example, I do it 2 times. Before each written array, there should be written a heading 'Title' and at the end of the written array should written text 'Total', therefore this is my desired outcome:
My code works only to write the 2 arrays for the first time but it does not write these 2 arrays for 2nd time. Instead, I am getting something else which is wrong:
This is my code:
Sub Write1()
Dim r As Long
Dim c As Long
Dim Start_Row As Long
Dim End_Row As Long
Dim main As Integer
Dim lngRowCount As Long
Dim w_Output As Worksheet
Dim w1 As Worksheet
Dim intLastRow As Integer
Const RowStart As Integer = 3
Const ColumnID As Integer = 1
Const Column_Desc As Integer = 3
Dim arrID() As Variant
Dim arrDesc() As Variant
With ThisWorkbook
Set w1 = .Sheets("Input")
Set w_Output = .Sheets("Output")
End With
'***********************************
'arrays
With w1
intLastRow = .Cells(Rows.Count, 1).End(xlUp).Row
'IntLastCol = .Cells(4, Columns.Count).End(xlToLeft).Column
arrID = .Range(.Cells(RowStart, ColumnID), .Cells(intLastRow, ColumnID))
arrDesc = .Range(.Cells(RowStart, Column_Desc), .Cells(intLastRow, Column_Desc))
'******************************************
main = 1
End_Row = 2 'this is the 2nd iteration to write arrays
For Start_Row = 1 To End_Row
w_Output.Cells(main, 3) = "Title"
main = main + 1
For r = 1 To UBound(arrID, 1)
If Len(arrID(r, 1)) > 0 Then
'Write
w_Output.Cells(r + 1, 3) = arrID(r, 1)
w_Output.Cells(r + 1, 4) = arrDesc(r, 1)
End If
main = main + 1
w_Output.Cells(main, 3) = "Total "
Next r
main = main + 4
Next Start_Row
End With
MsgBox "Done", vbInformation
End Sub
Does anybody know what I do wrong in my loop to make it work?
I have figured it out, it turns out the I was simply supposed to use 'main' as the row to write to the sheet and not 'r' which is used for the arrays - this is part of the code where arrays are written to the sheet.
Sub Write1()
Dim r As Long
Dim c As Long
Dim d As Long
Dim Start_Row As Long
Dim End_Row As Long
Dim main As Integer
Dim lngRowCount As Long
Dim w_Output As Worksheet
Dim w1 As Worksheet
Dim intLastRow As Integer
Dim IntLastCol As Integer
Const RowStart As Integer = 3
Const ColumnID As Integer = 1
Const Column_Desc As Integer = 3
Dim arrID() As Variant
Dim arrDesc() As Variant
With ThisWorkbook
Set w1 = .Sheets("Input")
Set w_Output = .Sheets("Output")
End With
'***********************************
'arrays
With w1
intLastRow = .Cells(Rows.Count, 1).End(xlUp).Row
arrID = .Range(.Cells(RowStart, ColumnID), .Cells(intLastRow, ColumnID))
arrDesc = .Range(.Cells(RowStart, Column_Desc), .Cells(intLastRow, Column_Desc))
'******************************************
main = 1
End_Row = 2
For Start_Row = 1 To End_Row
w_Output.Cells(main, 3) = "Title"
main = main + 1
For r = 1 To UBound(arrID, 1)
If Len(arrID(r, 1)) > 0 Then
'Write
w_Output.Cells(main, 3) = arrID(r, 1)
w_Output.Cells(main, 4) = arrDesc(r, 1)
End If
main = main + 1
Next r
w_Output.Cells(main, 3) = "Total "
main = main + 4
Next Start_Row
End With
MsgBox "Done", vbInformation
End Sub
It works perfectly.