Freeze on close after ListObject Resize - vba

I have an Excel file that takes data from outside and writes it in a ListObject.
As adding rows one by one through ListRows.Add is very slow, I add the right number of empty rows to the sheet and resize the ListObject.
This works really well in Excel 2010.
With Excel 2007, it works but when the user closes the workbook or Excel, it freezes and Windows displays its crash window (asking if you want to close, restart or debug the application).
This is really annoying and doesn't look very good :).
Any idea of what I could do to prevent that?
Maybe you have a better idea to quicky ladd thousands of rows in a ListObject?
Moreover randomly (I reopen the file change nothing and execute the macro), Resize fails with an error message and Excel crashes if I stop the execution.
Here is the function that adds the empty rows, if I follow it step by step it all the ranges are correct and it does what I need.
I'm pretty sure this is this function that causes the problem as it disappears when I comment the call to that function.
Sub AddRowsToListObject(sheetName As String, myTable As ListObject, addRows As Long)
Dim i As Long
If addRows > 0 Then
Sheets(sheetName).Activate
'Add empty rows at the end
i = myTable.DataBodyRange.row + myTable.ListRows.Count
Sheets(sheetName).Range(Cells(i, 1), Cells(i + addRows - 2, 1)).EntireRow.Insert shift:=xlDown
'Offset -1 as you need to include the headers again
myTable.Resize myTable.DataBodyRange.Offset(-1, 0).Resize(myTable.ListRows.Count + addRows, myTable.ListColumns.Count)
End If
End Sub

Unfortunately I don't have Excel 2007 and cannot replicate the error described in the question. However and assuming that:
The code is not trying to add rows beyond the capacity of Excel 2007
The error is caused by the method used to add new lines to the existing ListObject
And since you are asking for an alternative method to add thousands of rows to an existing ListObject
Try the code below
Sub ListObjects_AddRows(myTable As ListObject, addRows As Long)
If addRows > 0 Then
With myTable.DataBodyRange
.Offset(.Rows.Count, 0).Resize(addRows, 1).EntireRow.Insert
With .Offset(.Rows.Count, 0).Resize(addRows, 1)
.Value = "X"
.ClearContents
End With: End With: End If
End Sub

add Application.ScreenUpdating = False right after the start of the sub
add Application.ScreenUpdating = True right before the end
If you are doing 1000s then you definitely don't need the screen refreshing each time a new line gets drawn. Change that and it will only redraw it once it is finished.

After a lot of painful testing, it looks like the problem is not in this method but in the deleting of the rows just before that :
Sub ResetListObject(myTable As ListObject)
myTable.DataBodyRange.ClearContents
If myTable.DataBodyRange.Rows.Count > 1 Then
myTable.DataBodyRange.Offset(1, 0).Resize(myTable.DataBodyRange.Rows.Count - 1, myTable.DataBodyRange.Columns.Count).EntireRow.Delete shift:=xlUp
End If
End Sub
Excel 2010 requires you to always keep 1 row when you empty the ListObject.
But Excel 2007 requires 2 rows !!
I don't know why and I can't find any information on that.
I changed my script to delete all rows except 2 and changed the function in the OP to manage that fact.

Related

VBA MS Project. How to move entries of lookuptable programmatically?

I have an issue. I'm working on VBA macros in MS Project 2013, that can automatically fill and change lookup table, which linked with local custom field in project professional. I have these code sections on VBA for:
-adding entries
Set objStateEntry = objOutlineCode.LookupTable.AddChild(entryName)
-changing descrption of entries
objStateEntry.Description = "some description"
-changing level of entires
objStateEntry.level = entryLevel
But I can't find how to programmatically move entries up/down in lookup table. In other words I need to use marked in the screenshot buttons programmatically. Please help me. Thank you!
Try something like this:
Private Sub SpinButton1_SpinDown()
On Error Resume Next
If ListBox1.ListIndex = ListBox1.ListCount - 1 Then Exit Sub
With Me.ListBox1
.ListIndex = .ListIndex + 1
End With
End Sub
Private Sub SpinButton1_SpinUp()
On Error Resume Next
If ListBox1.ListIndex = 0 Then Exit Sub
With Me.ListBox1
.ListIndex = .ListIndex - 1
End With
End Sub
goodluck
I tried recording a macro while using the spin button you highlighted, but this indicates that VBA can't control the spin button...
So it seems the only way to change the index of a lookup table entry by VBA is to first delete the entry then add it back, for example moving entry at index=4 up to index=2 (after saving the name and description of entry index=4):
Dim lteName As String
Dim lteDesc As String
lteName = Application.CustomFieldValueListGetItem(pjCustomResourceOutlineCode2, pjValueListValue, 4)
lteDesc = Application.CustomFieldValueListGetItem(pjCustomResourceOutlineCode2, pjValueListDescription, 4)
Application.CustomFieldValueListDelete FieldID:=pjCustomResourceOutlineCode2, Index:=4
Application.CustomFieldValueListAdd FieldID:=pjCustomResourceOutlineCode2, Value:=lteName, Description:=lteDesc, Index:=2
Two caveats:
1: It appears you can't do the above in the same macro that you are adding the lookup table entries. It only works in another macro run after adding the entries.
2: At least in my version of MS Project, the index number is flaky (it should be consecutive but sometimes index numbers repeat or there are gaps but then it corrects itself!), no doubt due to deleting and adding entries like I am suggesting. The code won't work if the index numbers that VBA is looking for don't match what is displayed in the lookuptable window. Oh dear... wish MSProject was perfect!
Noted same behaviour on another SO thread here.

Do While ActiveCell <> Range

I have this VBA excel macro code
Sub fillcells()
Range("J14").Select
Do While ActiveCell <> Range("J902")
ActiveCell.Copy
ActiveCell.Offset(6, 0).Select
ActiveCell.PasteSpecial
Loop
End Sub
At first it was working fine but now sometimes when I try to run the macro the loop suddenly stops at cell J242, other times is arising an error 'mismatch type' and sometimes the macro just select cell J14 without doing the loop
Not sure what you want to do, but (as noted in the comments to your OP), don't use .Select/.Activate. The following should do what (I think) you wanted:
Sub fillcells()
Dim i& ' Create a LONG variable to count cells
For i = 14 To 901 Step 6
Cells(i, 10).Offset(6, 0).FormulaR1C1 = Cells(i, 10).FormulaR1C1
Loop
End Sub
This will loop from cell J14 to J901, copy/paste* to a cell 6 rows offset.
* Note I didn't actually copy/paste. Since your original code used PasteSpecial, I'm assuming you just want the values pasted. In this case, you can set the two ranges/cells equal.
Just an addition to what #BruceWayne already said: whenever you have this typical phenomenon that something happens only "sometimes" it is often a case of using keywords such as Active or Current or Selection. These are not specific but change each time that you call the macro. Whatever you have selected is the starting point. You might even start clicking around and thus change Selection while the macro is running. In short, you should start coding explicitly and don't allow VBA / Excel to assume / make the decision for you.
Let's start with Range("J14").Select. This line of code asks VBA to make already two assumptions:
If you have several Excel files open. Which Excel file should it start with?
Within the file there might be several sheets. On which of these sheets should J14 be selected?
Explicit coding means that you (hopefully at all times) be very specific what you are referring to. So, instead of just stating Range("J14") you should use:
ThisWorkbook.Worksheets("SheetNameYouWantToReferTo").Range("J14")
But is pointed out in the other answer, this is not even necessary in this case. Rather loop the rows as shown and use:
ThisWorkbook.Worksheets("SheetNameYouWantToReferTo").Cells(i, 10).Offset(6, 0).Formula = ThisWorkbook.Worksheets("SheetNameYouWantToReferTo").Cells(i, 10).Offset(i, 10).Formula
Since this is a bit lengthy you can shorting it by using a With statement:
With ThisWorkbook.Worksheets("SheetNameYouWantToReferTo")
.Cells(i, 10).Offset(6, 0).Formula = .Cells(i, 10).Formula
End With

copy row to next free row on another spreadsheet on change

First off, I'm a noob when it comes to Macros and VBA, so please forgive me if I don't make sense.
I've got an Excel spreadsheet which is basically a list of users and their mobile phone numbers and some other bits (columns A-K are currently used) and it's ordered by rows.
What I need is a way of copying the whole row if I change a cell. So if I change the username, it copies the whole row of that user to the next blank row on a second sheet.
The purpose of this is to keep an audit trail allowing us to see who's previously used a number etc.
I found this: Copy row to another sheet in excel using VBA which is working as intended, but I can't for the life of me get it to a, copy the cells to the next free row, or b, not overwrite the existing entry.
This is the code I'm using:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim a As Range, rw As Range
For Each a In Selection.Areas
For Each rw In a.Rows
If rw.Row >= 2 Then
rw.EntireRow.Copy Sheet2.Cells(2 + (rw.Row - 2) * 3, 1)
End If
Next rw
Next a
End Sub
I'd really appreciate it if someone could help me customise it.
I'm using Excel 2010 on Win7.
Many thank in advance.
Typically the Intersect method is used to determine if the cell or cells receiving a change involve one or more columns that you are concerned with. You can add additional parameters; in this case, I've .Offset the Worksheet.UsedRange property down one row to make sure that row 1 is not involved.
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Columns(1), Me.UsedRange.Offset(1, 0)) Is Nothing Then
On Error GoTo bm_Safe_Exit
Application.EnableEvents = False 'not really necessary in this case but never a bad idea within a Worksheet_Change
Dim a As Range
For Each a In Intersect(Target, Columns(1), Me.UsedRange.Offset(1, 0))
If CBool(Len(a.Value2)) Then _
a.EntireRow.Copy _
Destination:=Sheet2.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0) 'not really sure this is the correct destination
Next a
End If
bm_Safe_Exit:
Application.EnableEvents = True
End Sub
I've included a call to disable event handling for the duration of the Worksheet_Change event macro. While this is a critical step when the Worksheet_Change modifies values, it is not really important to incorporate here. However, it does not harm and is already in place in case you want to augment the Worksheet_Change to include something like a timestamp that would change the values on the worksheet.

Looping the whole cells to change a specific formula issue

I'm writing a function to change an entire column to new values using a formula, here's the code I'll elaborate more on the idea down there.
The problem is that it hangs and I have to rerun Excel and I'm not sure why.
Sub Button2_Click()
Dim i As Long
For i = 2 To Rows.Count
Cells(i, 4).Formula = "=B" & i & "+6*3600000/86400000+25569"
Next i
End Sub
So what's this about? I'm changing the fourth column to excel time because what I have in column B is epoch time, and this is the formula I'm using, it works with my case if I tried one by one, but for some reason it won't work as a whole. I'm not sure what's done wrong? But I'd appreciate your help.
Writing to cells one-by-one is very slow.
Writing formulas one-by-one is slower still, because each must be evaluated before Excel accepts them as formulas.
Doing this a million times can literally freeze Excel.
The solution is to write them all in one shot (no loops):
Sub Button2_Click()
[d2:d1048576] = "=B2+6*3600000/86400000+25569"
End Sub
' Another way of doing mass calculation is by using copy and paste method.
It will be better to convert the columns into values so that the sheet won't calculate again and again. It helps to prevent the sheet from hanging issues
Sub Button2_Click()
Range("D2").Formula = "=b1" & "+6*3600000/86400000+25569"
Range("D2").Copy
Range("D2:d1048576").PasteSpecial xlValues
Application.CutCopyMode = False
Range("D:D").Value = Range("D:D").Value
End Sub

how to write thusands of sub vba code quickly changing references

I want a module in my workbook to write about a thousand combinations of the below
Sub trade0001open()
Sheets("TRADEDIARY").Range("AO2").Value = 1
Sheets("TRADEDIARY").Range("AD3").Value = _
Sheets("TRADEDIARY").Range("AJ2").Value
Sheets("TRADEDIARY").Range("AD4").Value = _
Sheets("Sheet8").Range("HA1").Value + 1
Sheets("TRADEDIARY").Range("AO3").Value = 0
End Sub
Sub trade0001close()
Application.ScreenUpdating = False
Sheets("TRADEDIARY").Range("AI3").Value = Sheets("TRADEDIARY").Range("AI3").Value + 1
Sheets("TRADEDIARY").Range("AO3").Value = 1
Application.Wait (Now + 0.000001)
Sheets("TRADEDIARY").Range("AO3").Value = 0
Sheets("TRADEDIARY").Range("AO2").Value = 0
Sheets("TRADEDIARY").Range("AI2").Value = Sheets("TRADEDIARY").Range("AI2").Value + 1
Application.ScreenUpdating = True
End Sub
Changing changing the cell references by a cumulator of four rows down each time. So every AO2 would become AO6 in the next every AD3 becomes AD7. Everything apart from HA1 would change so that includes AO2,AD3,AJ2,AD4,AO3 for the first sub and then that includes AI3, AO3, AO2, AI2 for the second sub.
So since my code above contains the two subs I'd like copied a thousand times - each copy will add 4 rows to each cel reference in each sub.
I am quite new to vba so I guess I am after a similar autofill function like in excel except for my code to do this quickly instead of typing thousands of times unless of course I guess somebody could suggest how to do this differently. hint hint. bare in mind I obviously want all the values pasted without a clipboard so that when those values from where they are copied change, the destination doesn't change. Which is what my above code achieves.
Then I'd like to asign each individual sub within each of the two separately to a developer button control in the spread sheet ( again asigned to change four rows down each time)
#matteo to clarify ''well I envisioned the only way was to have 1000 trade0001open() and 1000 trade001close() possibly defined as trade0001open() , trade0002open() etc ditto close etc etc in order to right click for each one on a vba developer for control button alligned to each cell AK4 for open button and AM4 for close button so AK8 and AM8 etc etc which is long winded again and Im refraining from assuming a developer button could be alligned to each of those cells frm within vba and assigned to each of the sub at the moment. I guess one workaround might be to configure the j somehow into the sub name .''
matteo's reply: ''What you ask is complex to answer here, i will give you a tip to get started: use always the same macro but intercept the reference of the cell from which the call starts in order to add dinamically the 4 rows as I showed you above. You don't need 2000 macros, only 2 that are readapting themselves depending on the caller parent''
me : ''so I guess this is more complicated than it seems if I could somehow make form button's alligned to cells to reference the j value within the 2 macros without need for making thousands of sub macros. As far as I know form buttons in excel can only reference sub functions without reference and not UDFs or anything else or even cell references although I probably am wrong about this. ''
a form button to call the sub based on a cell's reference that is what I need right?
http://www.mrexcel.com/forum/excel-questions/843078-loop-visual-basic-applications-sub-call-form-button-each-nth-row-based-cell-value-row-reference.html#post4105072
I don't know for the life of me where to begin Trying to call a Sub with a String - VBA
You just need to make every string dinamically redefined and loop 1000 times the same macro. This is an example to get started:
For j = 1 To 1000 '<-- do this 1000 times
'...
Sheets("TRADEDIARY").Range("AO" & 2 + (j-1)*4).Value = 1 '<-- if j=1 then row = 2, if j=2 then row = 2+4 = 6 etc.
'...
Next j