VBA code works in debug mode but fails to run as macro - vba

Hey i have a small problem that i can´t seam to solve... Im not the first to have this problem i found but none of the existing solutions worked on my code. so im stuck... The problem is that my code runs faster then what the functions can execute.
My code adds all worksheets that are of the same type together in a new sheet. And to indicate when how long every file is in the new sheet i want to change the interior of the last row to another color. My code can do that now but only in debug mode... and i don´t know how to "slow it down" so that i works whit my macro. Iv tried a delay function, DoEvent and adding a timer but none worked... Would really appreciate some tips on how to solve this or if there is a better way to do this. Thanks!
Sub MergeSheets()
Dim WorkSheetSource As Worksheet
Dim WorkSheetDestination As Worksheet
Dim RangeSource As Range
Dim RangeDestination As Range
Dim lngLastCol As Long
Dim lngSourceLastRow As Long
Dim lngDestinationLastRow As Long
Dim SheetName As String
Dim SkipSheets As String
'Set references up-front
Set WorkSheetDestination = ThisWorkbook.Worksheets("Import")
lngDestinationLastRow = LastOccupiedRowNum(WorkSheetDestination) '<~ defined below (and in Toolbelt)!
lngLastCol = LastOccupiedColNum(WorkSheetDestination) '<~ defined below (and in Toolbelt)!
'Set the initial destination range
Set RangeDestination = WorkSheetDestination.Cells(lngDestinationLastRow + 1, 1)
' (lngDestinationLastRow + 2) = what row to start adding on, 1 = start from column
' Skip this sheets ' the 2 makes a blank row between sheeeeets
SkipSheets = ("Import, Cover sheet, Control, Column description, Charts description")
'Loop through all sheets
For Each WorkSheetSource In ThisWorkbook.Worksheets ' Here i coud add a function where i can choose my Sheets?
DoEvents
'Make sure we skip the "Import" destination sheet!
If InStr(1, SkipSheets & ",", WorkSheetSource.Name & ",", vbTextCompare) = 0 Then
' Skip all Charts sheets
If InStr(WorkSheetSource.Name, "Status") Then
'Identify the last occupied row on this sheet
lngSourceLastRow = LastOccupiedRowNum(WorkSheetSource)
'Store the source data then copy it to the destination range
With WorkSheetSource
Set RangeSource = .Range(.Cells(3, 1), .Cells(lngSourceLastRow, lngLastCol)) ' 3 = what start row , 2 = how many columns
RangeSource.Copy Destination:=RangeDestination
End With
'Redefine the destination range now that new data has been added
LongDestinationLastRow = LastOccupiedRowNum(WorkSheetDestination)
Set RangeDestination = WorkSheetDestination.Cells(LongDestinationLastRow + 1, 1)
'LongDestinationLastRow.EntireRow.Interior.ColorIndex = 15
End If
' Find last row and give it colour
'Range("A" & Rows.Count).End(xlUp).Select
'ActiveCell.EntireRow.Interior.ColorIndex = 15
' don´t work... only in debugmode
End If
' **** Here the code works in debug mode but not in macro!*****
' Find last row and give it colour
Range("A" & Rows.Count).End(xlUp).Select
ActiveCell.EntireRow.Interior.ColorIndex = 15
'*************************************************************
Next WorkSheetSource
MsgBox "Done"
End Sub

Related

Sheet size and memory usage in excel

Each worksheet is getting to large memory wise, I found that if I copied the rows and columns that had data in them and put into a new sheet then deleted the old one and renamed the new one the same name I could shrink my workbook size by 1 to 3 megabytes, its not a memory problem exactly but my code seems to run quicker when the book is smaller. I downloaded a program that is sopposed to delete all unused cells but cannot get it to work.
Sub Reset_LastCell()
' http://support.microsoft.com/default...&Product=xlw2K
' Save the lastcell and start there.
Dim Sh As Worksheet
Dim A As Integer
For Each Sh In Worksheets
A = A + 1
If A >= 28 Then
Sh.Activate
Set lastcell = Cells.SpecialCells(xlLastCell)
' Set the rowstep and column steps so that it can move toward
' cell A1.
rowstep = -1
colstep = -1
' Loop while it can still move.
While (rowstep + colstep <> 0) And (lastcell.Address <> "$A$1")
' Test to see if the current column has any data in any
' cells.
If Application _
.CountA(Range(Cells(1, lastcell.Column), lastcell)) _
> 0 Then colstep = 0 'If data then stop the stepping
' Test to see if the current row has any data in any cells.
' If data exists, stop row stepping.
If Application _
.CountA(Range(Cells(lastcell.Row, 1), lastcell)) _
> 0 Then rowstep = 0
' Move the lastcell pointer to a new location.
Set lastcell = lastcell.Offset(rowstep, colstep)
' Update the status bar with the new "actual" last cell
' location.
Application.StatusBar = "Lastcell: " & lastcell.Address
Wend
' Clear and delete the "unused" columns.
With Range(Cells(1, lastcell.Column + 1), "IV65536")
Application.StatusBar = "Deleting column range: " & _
.Address
.Clear
.Delete
End With
' Clear and delete the "unused" rows.
With Rows(lastcell.Row + 1 & ":65536")
Application.StatusBar = "Deleting Row Range: " & _
.Address
.Clear
.Delete
End With
' Select cell A1.
' Reset the status bar to the Microsoft Excel default.
Application.StatusBar = False
If A >= 35 Then Exit Sub
Range("AI2").Select
End If
Next
End Sub
One very easy means of reducing the workbook size is to save the file as a .xlsb. All code and all functions continue to work exactely the same. The only limitation is that the workbook can no longer be opened by Libre Office and other open source spreadsheet applications.
I have found that it also helps to speed up calculations of formulas... it may help with code.
UPDATE
Your code works fine on my machine, the only thing I needed to do was add Dim to the code because i use Option Explicit. Add the following to your code at the top:
Dim lastcell As Range
Dim colstep As Long
Dim rowstep As Long

Select cells between bold cells using a loop

I am working with data where the only consistency is the layout and the bold headings to distinguish between a new date.
I am trying to find the cells in between these cells in bold, find the value "Individual" (in column A) in the selected rows, then sum the values of the given rows in column D (as there can be more then 1 row with "Individual"), and copy this new value to a different cell.
Since the cells between the bold is one date, if the value is not there, the output cell needs to shift down one without filling in anything.
Here is what I have so far:
Sub SelectBetween()
Dim findrow As Long, findrow2 As Long
findrow = range("A:A").Find("test1", range("A1")).Row
findrow2 = range("A:A").Find("test2", range("A" & findrow)).Row
range("A" & findrow + 1 & ":A" & findrow2 - 1).Select
Selection.Find("Individual").Activate
range("D" & (ActiveCell.Row)).Select
Selection.copy
sheets("Mix of Business").Select
range("C4").Select
ActiveSheet.Paste
Exit Sub
errhandler:
MsgBox "No Cells containing specified text found"
End Sub
How can I loop through the data and each time it loops through a range, no matter if it finds the value (e.g. individual) or not, shifts down one row on the output cell? Also, how can I change the findrow to be a format (Bold) rather then a value?
Here is some data for reference:
This is what I am trying to get it to look like:
So you have a good start to trying to work through your data. I have a few tips to share that can hopefully help get you closer. (And please come back and ask more questions as you work through it!)
First and foremost, try to avoid using Select or Activate in your code. When you look at a recorded macro, I know that's all you see. BUT that is a recording of your keystrokes and mouseclicks (selecting and activating). You can access the data in a cell or a range without it (see my example below).
In order to approach your data, your first issue is to figure out where your data set starts (which row) and where it ends. Generally, your data is between cells with BOLD data. The exception is the last data set, which just has a many blank rows (until the end of the column). So I've created a function that starts at a given row and checks each row below it to find either a BOLD cell or the end of the data.
Private Function EndRowOfDataSet(ByRef ws As Worksheet, _
ByVal startRow As Long, _
Optional maxRowsInDataSet As Long = 50) As Long
'--- checks each row below the starting row for either a BOLD cell
' or, if no BOLD cells are detected, returns the last row of data
Dim checkCell As Range
Set checkCell = ws.Cells(startRow, 1) 'assumes column "A"
Dim i As Long
For i = startRow To maxRowsInDataSet
If ws.Cells(startRow, 1).Font.Bold Then
EndRowOfDataSet = i - 1
Exit Function
End If
Next i
'--- if we make it here, we haven't found a BOLD cell, so
' find the last row of data
EndRowOfDataSet = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
End Function
To show you how to use that with your specific data, I've created a test subroutine indicating how to loop through all the different data sets:
Option Explicit
Public Sub DataBetween()
Dim thisWB As Workbook
Dim dataWS As Worksheet
Set thisWB = ThisWorkbook
Set dataWS = thisWB.Sheets("YourNameOfSheetWithData")
'--- find the first bold cell...
'Dim nextBoldCell As Range
'Set nextBoldCell = FindNextBoldInColumn(dataWS.Range("A1"))
'--- now note the start of the data and find the next bold cell
Dim startOfDataRow As Long
Dim endOfDataRow As Long
Dim lastRowOfAllData As Long
startOfDataRow = 3
lastRowOfAllData = dataWS.Cells(ws.Rows.Count, "A").End(xlUp).Row
'--- this loop is for all the data sets...
Loop
endOfDataRow = EndRowOfDataSet(dataWS, startOfDataRow)
'--- this loop is to work through one data set
For i = startOfDataRow To endOfDataRow
'--- work through each of the data rows and copy your
' data over to the other sheet here
Next i
startOfDataRow = endOfDataRow + 1
Do While endOfDataRow < lastRowOfAllData
End Sub
Use both of those together and see if that can get you closer to a full solution.
EDIT: I should have deleted that section of code. It was from an earlier concept I had that didn't completely work. I commented out those lines (for the sake of later clarity in reading the comments). Below, I'll include the function and why it didn't completely work for this situation.
So here's the function in question:
Public Function FindNextBoldInColumn(ByRef startCell As Range, _
Optional columnNumber As Long = 1) As Range
'--- beginning at the startCell row, this function check each
' lower row in the same column and stops when it encounters
' a BOLD font setting
Dim checkCell As Range
Set checkCell = startCell
Do While Not checkCell.Font.Bold
Set checkCell = checkCell.Offset(1, 0)
If checkCell.Row = checkCell.Parent.Rows.Count Then
'--- we've reached the end of the column, so
' return nothing
Set FindNextBoldInColumn = Nothing
Exit Function
End If
Loop
Set FindNextBoldInColumn = checkCell
End Function
Now, while this function works perfectly well, the situation is DOES NOT account for is the end of the last data set. In other words, a situation like this:
The function FindNextBoldInColumn will return nothing in this case and not the end of the data. So I (should have completely) deleted that function and replaced it with EndRowOfDataSet which does exactly what you need. Sorry about that.

Copy part of cells that varies in both length and content using VBA

So I have workbook1 (wbThis) and workbook2 (wbTarget) and in wbThis' sheet I have some cells which are filled. These cells have the format of:
From A6
P2123: Begin procedure
A7
P1234: Code
A8
P4456-6: Document
|
V
(down arrow)
A27
It continues like that. Now I have 2 issues.
Problem1 I want to copy the PXXXxX: (small x is like an arbitrary summation of - or _ or > etc etc) codes to wbTarget. This code varies as you can see but there will always be a "P" in the beginning and a ":" at the end. Regarding this, I have tried with the code:
Dim wbThis As Workbook
Dim wbTarget As Workbook
Dim rowRng As Integer
Dim targetRowRng As Integer
For rowRng 6 To 27
For targetRowRng 14 To 35
If Left((A:rowRng).Value,1) = "P" Then
wbThis.Sheets("Sheet1").Range(A:rowRng).Copy
wbTarget.Sheets("Sheet1").Range(E:targetRowRng).PasteSpecial
End If
Next
Next
However, as you may have noticed, I have not wrote the code where I want it to end on ":" and copy everything inbetween (including "P" but excluding ":").. I don't know how to code this and I would like your help.
Since the length of PXXXxX varies - something like:
If Left((A:rowRng).Value,1) = "P" Then
If Left((A:rowRng).Value,5) = ":" Then
won't work, unfortunately.
Problem2 Now there is no way to that all cells of wbThis' range of A6 -> A27 will be filled everytime there's a new document and because I don't want unnecessary copy/pasting I want the script to stop the copy/pasting of PXXXxX: if the script doesn't find a P in eg A16. (if there is no P there is no PXXXxX and then the cell will be empty and therefore redundant - the same applies to all cells under it within the same column)
I guess you can code this using else to the If statement above:
ElseIf
Pass 'Any code here that return to the rest of the script
This doesn't look right though, I haven't found much regarding this.
Try this code out. Change object names as needed. this will loop through each cell until A27, checking for the "P...:" combination.
Sub Test()
Dim wbThis As Workbook
Dim wbTarget As Workbook
Set wbThis = Workbooks("Workbook1.xlsx") 'change as needed
Set wbTarget = Workbooks("Workbook2.xlsx") 'change as needed
Dim wsThis As Worksheet
Dim wsTarget As Worksheet
Set wsThis = wbThis.Sheets("Sheet1")
Set wsTarget = wbTarget.Sheets("Sheet1")
Dim rowRng As Integer
Dim targetRowRange As Integer
targetRowRange = 14
For rowRng = 6 To 27
With wsThis
If Left(.Cells(rowRng, 1), 1) = "P" Then
Dim iPos As Integer
iPos = InStr(1, .Cells(rowRng, 1), ":")
wsTarget.Cells(targetRowRange, 5).Value = Left(.Cells(rowRng, 1), iPos - 1)
targetRowRange = targetRowRange + 1
End If
End With
Next
End Sub
Would
If Right((A:rowRng).Value,1) = ":" Then
be what you want? Alternatively one solution may be to replace the characters with "", e.g.
Replace (Replace ( your_string, "P", ""), ":","")

Copy cells in excel with vba

I have a code that reads in the new arrangement of columns from a text file and then rearrange the original columns by copying it in at the correct place, however there is a bug in my code. Instead of copying just 1 column it seems to copy all columns to the right of the column that i want to copy..
so i guess the error is here
'copy the old range
ws.Range(ws.Cells(Settings.rowHeader + 1, CounterCol), ws.Cells(lrow, CounterCol)).Copy
I want to copy the range AW3:AW80 to A3:A80, but do i need to copy AW:AW to A:A instead? If i do so the stuff in row 1 will be deleted, below is the full code:
Sub insertColumns()
Call Settings.init
Dim i As Integer
Dim ws As Worksheet
Dim lrow As Integer
Dim columNames As Object
Dim temp As Variant
'fill dictionary with columnnames from text file
Set columNames = FileHandling.getTypes(Settings.columnFile)
Set ws = ActiveWorkbook.Sheets("List")
'Get max column and row number
lColumn = HelpFunctions.getLastColumn(ws, Settings.rowHeader)
lrow = HelpFunctions.getLastRow(ws, HelpFunctions.getColumn("*part*", ws, Settings.rowHeader))
'Insert all new columns in reverse order from dictionary
temp = columNames.keys
For i = columNames.Count - 1 To 0 Step -1
ws.Columns("A:A").Insert Shift:=xlToRight
ws.Range("A" & Settings.rowHeader).Value = temp(i)
Next i
'last column
lastColumn = lColumn + columNames.Count
'we loop through old cells
CounterCol = columNames.Count + 1
Do While CounterCol <= lastColumn
j = 0
'through each elemnt in dictionary
For Each element In temp
j = j + 1
'compare the old rowheader with any of the rowheader in DICTIONARY
If UCase(ws.Cells(Settings.rowHeader, CounterCol).Value) = element Then
'copy the old range
ws.Range(ws.Cells(Settings.rowHeader + 1, CounterCol), ws.Cells(lrow, CounterCol)).Copy
'paste it
ws.Cells(Settings.rowHeader + 1, j).Select
ws.Paste
'format the new row
ws.Cells(Settings.rowHeader + 1, j).EntireColumn.AutoFit
'Delete the old row
ws.Columns(CounterCol).EntireColumn.Delete
'decrease the last column by one since we just deleted the last column
lastColumn = lastColumn - 1
found = True
'Exit For
End If
Next element
'Prompt the user that the old column does not match any of the new column
If Not found Then
MsgBox (UCase(ws.Cells(Settings.rowHeader, CounterCol)) & " was not a valid column name please move manually")
End If
'reset the found
found = False
'go to nect column
CounterCol = CounterCol + 1
Loop
End Sub
Below is a screenshot of the dictionary.
After the first iteration/first copy it should have only copied over the part number column, but as can been seen it has copied over more than just the first column(everything except of drawing number)
Q: I want to copy the range AW3:AW80 to A3:A80, but do i need to copy AW:AW to A:A instead?
A: No. Any range can be copied.
Rather than trying to debug your code, I'll give you a hint about how to debug such a thing. Lines like
ws.Range(ws.Cells(Settings.rowHeader + 1, CounterCol), ws.Cells(lrow, CounterCol)).Copy
are hard to debug because they are trying to do too much. You have 4 instances of the dot operator and suspected that the problem was with the last one (.Copy). The problem is almost certainly that your code isn't grabbing the range that you think it is grabbing. In other words, one or more of your method invocations earlier in the line needs debugging. In such a situation it is useful to introduce some range variables, set them equal to various values and print their addresses to the immediate window to see what is happening. As an added benefit, having set range variables allows you to use the full power of intellisence in the VBA editor. Something like:
Dim SourceRange As Range, Cell1 As Range, Cell2 As Range
'
'
'
Set Cell1 = ws.Cells(Settings.rowHeader + 1, CounterCol)
Set Cell2 = ws.Cells(lrow, CounterCol)
Set SourceRange = ws.Range(Cell1, Cell2)
Debug.Print Cell1.Address & ", " & Cell2.Address & ", " & SourceRange.Address
'
'Once the above is debugged:
'
SourceRange.Copy 'should work as expected
It is possible that you are copying the range that you want to copy but that your larger program still isn't working. In that case you have some sort of logic error and should be trying to copy some other range. Even then, the above exercise still helps because it makes it clear exactly what your original line was doing.
'go to nect column
CounterCol = CounterCol + 1
needed to be deleted. It has to do that the column shifts left when i deleted rows.
Thanks for the help. I hope the code can be used for others who might need to add columns, but still copy over content from old columnsin the right order.

Quicker way to filter out data based on a particular value

I am working with a workbook that currently has 3 sheets. The first sheet is an overview where the filtered data will appear. Cell D11 has the color that I am looking for. Upon entering the color cells F3:I27 Populate with information like color, shape, number and animal.
C2C-Tracker2
I would use a Pivot Table for this, however, I have another set of data in K3:M27. This data is pulled from another sheet within the workbook with a similar function.
The formula that I am using is:
=IFERROR(INDEX(cases!A:A,SMALL(IF(EXACT($D$3,cases!$C:$C),ROW(cases!$C:$C)-ROW($F$1)+1),ROW(1:1))),"")
Of course it is entered using CTRL + SHIFT + ENTER for it to work properly.
I tried using a VBA Macro that I pulled from the video below:
Excel VBA Loop to Find Records Matching Search Criteria
So many array formulas can really make your workbook very slow.
Here is a code to populate Dataset1 using arrays. It runs in less than a second.
Hope this gets you started. I have commented the code but if you still have a problem understanding, just post back :)
Sub Sample()
Dim DSOne() As String
Dim tmpAr As Variant
Dim wsCas As Worksheet: Set wsCas = ThisWorkbook.Sheets("Cases")
Dim wsMain As Worksheet: Set wsMain = ThisWorkbook.Sheets("Sheet1")
Dim lRow As Long, i As Long, j As Long
'~~> Check if user entered a color
If wsMain.Range("D3").Value = "" Then
MsgBox "Please enter a color first", vbCritical, "Missing Color"
Exit Sub
End If
'~~> Clear data for input in main sheet
wsMain.Range("F3:F" & wsMain.Rows.Count).ClearContents
'~~> Get last row of Sheet Cases
lRow = wsCas.Range("A" & wsCas.Rows.Count).End(xlUp).Row
With wsCas
'~~> Get count of cells which have that color
i = Application.WorksheetFunction.CountIf(.Columns(3), wsMain.Range("D3").Value)
'~~> Check if there is any color
If i > 0 Then
'~~> Define your array to hold those values
ReDim DSOne(1 To i, 1 To 4)
'~~> Store the Sheet Cases data in the array
tmpAr = .Range("A1:D" & lRow).Value
j = 1
'~~> Loop through the array to find the matches
For i = LBound(tmpAr) To UBound(tmpAr)
If tmpAr(i, 3) = wsMain.Range("D3").Value Then
DSOne(j, 1) = tmpAr(i, 1)
DSOne(j, 2) = tmpAr(i, 2)
DSOne(j, 3) = tmpAr(i, 3)
DSOne(j, 4) = tmpAr(i, 4)
j = j + 1
End If
Next i
'~~> write to the main sheet in 1 Go!
wsMain.Range("F3").Resize(UBound(DSOne), 4).Value = DSOne
End If
End With
End Sub
Screenshot:
Using the above approach now populate Dataset2 :)