Search and Copy Excel Data with VBA - vba

I'm writing a VBA program to search through a large spreadsheet and copy rows that have the same account five or more times associated with the data to a different sheet. The program does exactly what it's supposed to do when I step through each individual line (F8), but when I run the program (F5), it doesn't end up copying any information to the second sheet. I've tried adding a two second delay between switching sheets and pasting the data, just in case this was the problem, but so far it hasn't helped.
Any suggestions?
Edit: I thought that the screen updating might be causing the problem, so I disabled it. The program still didn't paste the data in the other worksheet.
Second Edit: I noticed that when I put a stop in at the beginning of the while loop and step the program through in chunks, it also does not copy and paste the data like it should be. It still works when stepping through individual lines of code, though. I also removed the 2 second pauses as those didn't make a difference.
Here's the code:
Public Sub Main()
Worksheets(2).Activate
Range("A1").Select
Worksheets(1).Activate
Range("C2").Select
AcctName = ActiveCell.Value
LoopControl = 0
AcctNameCt = 1
CurrentAcctRow = ActiveCell.Row
Do While LoopControl <> 1
SecondLoopControl = 0
If AcctName = ActiveCell.Offset(AcctNameCt, 0).Value Then
AcctNameCt = AcctNameCt + 1
If AcctNameCt > 4 Then
GreaterThanFour
End If
ElseIf ActiveCell.Offset(AcctNameCt, 0).Value = "" Then
Exit Do
Else
ActiveCell.Offset(AcctNameCt, 0).Activate
AcctName = ActiveCell.Value
AcctNameCt = 1
CurrentAcctRow = ActiveCell.Row
End If
Loop
End Sub
Public Sub CopyData()
Dim EndRow As Integer
Dim StopCopy As Integer
Dim RestartRow As Integer
EndRow = CurrentAcctRow + AcctNameCt
StopCopy = EndRow - 1
RestartRow = EndRow + 1
ActiveSheet.Range("C" & CurrentAcctRow & ":" & "C" & StopCopy).EntireRow.Copy
Worksheets(2).Activate
LookForEmptyRow
ActiveCell.EntireRow.PasteSpecial
CurrentAcctRow = CurentAcctRow + 1
Worksheets(1).Activate
Range("C" & EndRow).Select
AcctNameCt = 0
End Sub
Public Sub GreaterThanFour()
Do While SecondLoopControl <> 1
If AcctName = ActiveCell.Offset(AcctNameCt, 0).Value Then
AcctNameCt = AcctNameCt + 1
Else
CopyData
SecondLoopControl = 1
End If
Loop
End Sub
Public Sub LookForEmptyRow()
Range("A1").Select
Dim LookAnotherLoopControl As Integer
LookAnotherLoopControl = 0
Do While LookAnotherLoopControl <> 1
If ActiveCell.Value = "" Then Exit Sub Else ActiveCell.Offset(1, 0).Activate
Loop
End Sub

I set the worksheet names to variables and called those, rather than calling the worksheets directly. For some reason, this works better.
Set wbA = Workbooks(Workbook Name)
Set wsA = Worksheets(Worksheet Name 1)
Set wsB = Worksheets(Worksheet Name 2)
Where the "Workbook Name" and "Worksheet Name 1" reflect the actual names, instead. Those are working better than:
Worksheets(2).Activate
LookForEmptyRow
ActiveCell.EntireRow.PasteSpecial
CurrentAcctRow = CurentAcctRow + 1
Worksheets(1).Activate
Range("C" & EndRow).Select
I also used a better method to look for an empty row, rather than writing my own subroutine. The original code had this sub that I wrote:
Public Sub LookForEmptyRow()
Range("A1").Select
Dim LookAnotherLoopControl As Integer
LookAnotherLoopControl = 0
Do While LookAnotherLoopControl <> 1
If ActiveCell.Value = "" Then Exit Sub Else ActiveCell.Offset(1, 0).Activate
Loop
Which, while effective, was highly inefficient. I replaced it with the much more efficient line of code:
lRow = Range("A1000").End(xlUp).Row
Cells(lRow + 1, 1).Activate

Related

How to Loop Range number in Excel VBA without changing letter

How do I get this to work?
I have this code written so far:
Sub RemoveLoop()
Dim i As Long
For i = 6 To 15
If Range("B" + i) = "YES" Then
Range("C" + i + ":" + "P" + i).ClearContents
End If
Next i
End Sub
Instead of doing each individually like this:
This is what I'm trying to shorten/accomplish, below:
Sub Remove()
If Range("B6") = "YES" Then
Range("C6:P6").ClearContents
End If
If Range("B7") = "YES" Then
Range("C7:P7").ClearContents
End If
If Range("B8") = "YES" Then
Range("C8:P8").ClearContents
End If
If Range("B9") = "YES" Then
Range("C9:P9").ClearContents
End If
If Range("B10") = "YES" Then
Range("C10:P10").ClearContents
End If
If Range("B11") = "YES" Then
Range("C11:P11").ClearContents
End If
If Range("B12") = "YES" Then
Range("C12:P12").ClearContents
End If
If Range("B13") = "YES" Then
Range("C13:P13").ClearContents
End If
If Range("B14") = "YES" Then
Range("C14:P14").ClearContents
End If
If Range("B15") = "YES" Then
Range("C15:P15").ClearContents
End If
End Sub
Simple question for you guys, thank you for your help.
I don't know what else to say, it's pretty straight forwards I believe. But I'm still getting the, "Looks like your most is mostly code error."
This should be an easy one for you VBA experts to solve.
Thanks again.
Try this:
Sub RemoveLoop()
Dim i As Long
Set WSheet = Worksheets("Sheet1") ' This enables the change in the mentioned sheet and not the Active sheet.
For i = 6 To 15
If WSheet.Range("B" & i) = "YES" Then
WSheet.Range("C" & i & ":P" & i).ClearContents
End If
Next i
End Sub
This is what you can do, passing the cells and the ranges as variables:
Option Explicit
Sub RemoveLoop()
Dim i As Long
For i = 6 To 15
With Worksheets(1)
If UCase(.Range("B" & i)) = "YES" Then
.Range(.Cells(i, "C"), .Cells(i, "P")).ClearContents
End If
End With
Next i
End Sub
Except for using Range(Cells,Cells), the code is refering to UCase, which makes sure that "yes" and "YES" in column "B" are treaten equally.

VBA code to shift columns over and maintain formula

Hi guys so this is my code:
Sub Biz1_Shift_OnePeriod()
'Shift all values one period to the left
'Message Box Question
Ans = MsgBox("Update data by one year?", vbYesNo + vbQuestion, "Data Update")
If Ans = vbNo Then Exit Sub
'Turn off screen updating & calculation to make code run faster
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Dim CopyFromWks As Worksheet
Dim CopyToWks As Worksheet
Dim j As Integer
Dim C As Range
'---------------------------------------------------------------------
'Business - Balance Sheet
'
'
'Set the worksheet
Sheets("Balance Sheet").Select
Range("A2").Select
Set CopyToWks = Sheets("Balance Sheet")
Set CopyFromWks = Sheets("Balance Sheet")
'
'Copy data loop from 2nd Historical to 3rd Historical
Set Copyfrom = CopyFromWks.Range("L:L")
Set Copyto = CopyToWks.Range("I:I")
For i = 1 To 1
For j = 1 To 95
For Each C In Copyfrom.Cells(j, i)
If C.Locked = False Then
Copyto(j, i).Value = Copyfrom(j, i).Value
End If
Next
Next
Next
'
'Copy data loop from 1st Historical to 2nd Historical
Set Copyfrom = CopyFromWks.Range("O:O")
Set Copyto = CopyToWks.Range("L:L")
For i = 1 To 1
For j = 1 To 95
For Each C In Copyfrom.Cells(j, i)
If C.Locked = False Then
Copyto(j, i).Value = Copyfrom(j, i).Value
End If
Next
Next
Next
'
'Set Historical Yr 1 to Zero
Set Copyto = CopyToWks.Range("O:O")
For i = 1 To 1
For j = 1 To 95
For Each C In Copyfrom.Cells(j, i)
If C.Locked = False Then
Copyto(j, i).Value = 0
End If
Next
Next
Next
'
'Set Current equal to Zero
Set Copyto = CopyToWks.Range("R:R")
For i = 1 To 1
For j = 1 To 95
For Each C In Copyto.Cells(j, i)
If C.Locked = False Then
Copyto(j, i).Value = 0
End If
Next
Next
Next
What I want to do is shift my columns over to the left. I thought a copy paste method would do and for now I have the last column set to 0. However, I need the last column to retain all its formulas, but have it not be pulling from any data source. I came up with an idea to create another column that would be hidden and storing all the formula there and have that shift over when the macro is triggered. I wanted to ask you guys if there is a better way of going about this and help brainstorm a little bit.
Try
Selection.PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False

Copy non-blank cell into cell below, repeat for each blank cell

I have an Excel dataset that has a string in A1, and other values in B1, B2, and B3 that relate to A1; and so on down the page. Sometimes there are more than three cells that relate to the other string (unpredictable). In this example, cells A2 and A3 are blank. I want to create a macro that will fill A2 and A3 (etc) with the contents of A1.
In the example below I am using [] to help format it as Excel cells. I want to go from:
[SMITH, John] [Home]
[Mobile]
[Work]
[DOE, John] [Home]
[Mobile]
to
[SMITH, John] [Home]
[SMITH, John] [Mobile]
[SMITH, John] [Work]
[DOE, John] [Home]
[DOE, John] [Mobile]
I want the macro to repeat this for varying iterations, sometimes I have 1000 lines to adjust manually. Tweaking the software that outputs the data is not an option.
The code I have is as follows:
Sub rname()
Dim cellvar As String
Dim i As Integer
cellvar = ActiveCell
i = 0
While i < 50
If ActiveCell.Offset(1,0) = "" Then
ActiveCell.Offset(1,0) = cellvar
i = i + 1
ElseIf ActiveCell.Offset(1,0) = "*" Then
ActiveCell.Offset(1,0).Activate
i = i + 1
End If
Wend
End Sub
The above code adds text to the cell below the active cell once and then stops responding. The following code runs once and doesn't stop responding - I can run it again, but it doesn't automatically move down a row.
Sub repeat_name()
Dim cellvar As String
Dim i As Integer
cellvar = ActiveCell
i = 1
For i = 1 To 50
If ActiveCell.Offset(1, 0) = "" Then
ActiveCell.Offset(1, 0) = cellvar
End If
If ActiveCell.Offset(1, 0) = "*" Then
ActiveCell.Offset(1, 0).Select.Activate 'I have tried .Offset(2,0)too
End If
i = i + 1
Next
End Sub
I am stumped here. Does anyone have any thoughts or suggestions?
Try it as,
Sub fillBlanks()
With Worksheets("Sheet1")
With .Range(.Cells(2, "B"), .Cells(Rows.Count, "B").End(xlUp))
With .Offset(0, -1).SpecialCells(xlCellTypeBlanks)
.FormulaR1C1 = "=R[-1]C"
End With
With .Offset(0, -1)
.Value = .Value
End With
End With
End With
End Sub
                       Before fillBlanks procedure                    After fillBlanks procedure
Others have given working solutions, I'll just outline the problems with your code.
cellvar = ActiveCell assigns the value of the active cell to cellvar but cellvar won't change if ActiveCell changes so you'll just copy [SMITH, John] for all other people. You'd have to reassign cellvar.
If ActiveCell.Offset(1, 0) = "*" Then This checks if the cell contains an asterisk. Instead use Not ActiveCell.Offset(1, 0) = "", ActiveCell.Offset(1, 0) <> "", Not isEmpty(ActiveCell.Offset(1, 0)) or just Else (which would be the preferred version here since it doesn't require further calculations).
Edit: "*" Can be used as a wildcard with the Like operator as in If ActiveCell.Offset(1, 0) Like "*" Then but this would also be true for the empty string. To be sure that there is at least one sign you'd have to use "?*" instead. The question mark stands for exactly one character and the asterisk for 0 or more. To check if a cell is empty I would recommend one of the above ways though.
In you first sub this means that if the cell anything but "*", i will not be incremented and you end in an endless loop. In the second function, it means that the the active cell will not be changed and neither "" not "*" will be detected for the rest of the loop.
In the second sub, you don't need i=i+1, the for loop does that for you. This would mean that you increment i by 2 every iteration.
ActiveCell.Offset(1, 0).Select.Activate Here the "select" is too much
Here are the subs with minimal changes:
Sub rname()
Dim cellvar As String
Dim i As Integer
cellvar = ActiveCell
i = 0
While i < 50
If ActiveCell.Offset(1, 0) = "" Then
ActiveCell.Offset(1, 0) = cellvar
ActiveCell.Offset(1, 0).Activate 'the code will run without this but need to iterations per row
i = i + 1
MsgBox "a " & i
Else
ActiveCell.Offset(1, 0).Activate
cellvar = ActiveCell 'reassign cellvar
i = i + 1
MsgBox "b " & i
End If
Wend
End Sub
second sub:
Sub repeat_name()
Dim cellvar As String
Dim i As Integer
cellvar = ActiveCell
'i = 1 'this is not necessary
For i = 1 To 50
If ActiveCell.Offset(1, 0) = "" Then
ActiveCell.Offset(1, 0) = cellvar
End If
If Not ActiveCell.Offset(1, 0) = "" Then 'if else endif would be nicer here
ActiveCell.Offset(1, 0).Activate 'remove "select"
cellvar = ActiveCell 'reassign cellvar
End If
'i = i + 1 'this is not necessary/wrong
Next i 'safer to include i
End Sub
Note that this is just to explain the problems with your code, I still recommend to use one of the other solutions here.
Try this:
Sub repeat_name()
Dim cellvar As String
Dim i As Integer
Dim ws As Worksheet
Set ws = Sheet1 'Change according to your sheet number
cellvar = ""
For i = 1 To 50
if Trim(ws.Range("A" & i )) <> "" then
cellvar = Trim(ws.Range("A" & i ))
Else
ws.Range("A" & i ) = cellvar
End if
Next i
End Sub
How about this:
Sub FillBlanks()
Columns("A:A").Select
Selection.SpecialCells(xlCellTypeBlanks).Select
Selection.FormulaR1C1 = "=R[-1]C"
End Sub
try this:
Sub repeat_name()
Dim k As Integer
Dim i As Integer
i = 1
k = ActiveSheet.UsedRange.Rows.Count
While i <= k
With ActiveSheet
If .Range("A1").Value = "" Then
MsgBox "Error: First cell can not be empty."
Exit Sub
End If
If .Range("A" & i).Value = "" And .Range("B" & i).Value <> "" Then
.Range("A" & i).Value = .Range("A" & i - 1).Value
End If
End With
i = i + 1
Wend
End Sub
try this
Sub test()
lastrow = Range("B" & Rows.Count).End(xlUp).Row
For i = 2 To lastrow
If Cells(i, 1) = "" Then
Cells(i, 1) = Cells(i - 1, 1)
End If
Next i
End Sub

Getting the difference of the cells

Anyone knows how to get the difference between the two cells with condition. My problem is that if Column W contains the value of FAILED, then I have to get the difference of Column P and Column Q and put the difference to Column Z. Then I have to do this up until the last row that has a data in Column W. I have this code so far:
If ws.Range("W3") = "FAILED" Then
ws.Range("Z3") = ws.Range("P3") - ws.Range("Q3")
Else
ws.Range("Z3") = ""
End If
ws.Range("Z3").Copy
ws.Range("Z3:Z" & GetLastRow(ws)).PasteSpecial xlPasteValues
Any help? Thanks!
Sub GetDiff()
Dim Ws As Worksheet, lRw As Long
Set Ws = ActiveSheet
Application.ScreenUpdating = False
With Ws
lRw = .Range("W" & Rows.Count).End(xlUp).Row
With .Range("Z3:Z" & lRw)
.Formula = "=IF(W3=""Failed"",SUM(P3)-SUM(Q3),0)"
.Calculate
DoEvents 'This will let the formula to calculate before converting it to values
.Value = .Value
End With
End With
Application.ScreenUpdating = True
End Sub
If you really want to do this in VBA then you could change your code to:
Sub calc()
Dim ws As Object
Set ws = ActiveSheet
Row = 3
Do
If WorksheetFunction.CountA(ActiveSheet.Rows(Row)) = 0 Then Exit Do 'exit loop if row is empy
If ws.Cells(Row, 23).Text = "FAILED" Then
ws.Cells(Row, 26) = ws.Cells(Row, 16) - ws.Cells(Row, 17)
Else
ws.Cells(Row, 26) = ""
End If
Row = Row + 1
Loop
End Sub
Notice I favored numeric references to columns.
But unless you plan to escalate to a more complex case, I would stick with a formula on the Z column:
=IF(W1="FAILED",P1-Q1,"")

Error 1004 on VBA

I have five worksheet in all that are using the below code which is stored in a workbook. The first worksheet works perfectly well with the code. The second spreadsheet can check for the first item before returning the error. The subsequent third and fourth worksheet return the error immediately. The fifth worksheet on the other hand return error 400. May I know is my code the source of the problem or it's the checkbox because I copied and paste from the first worksheet.
Sub test5()
Dim MyFile As String
Dim FinalRow As Long
Dim Row As Long
Dim i As Integer
Dim d As Integer
d = 2
i = 0
FinalRow = Cells(Rows.count, "S").End(xlUp).Row
For Row = 3 To FinalRow
If Not IsEmpty(ActiveSheet.Cells(Row, "S")) Then
i = i + 1
d = d + 1
MyFile = ActiveSheet.Cells(Row, "S").Value
If Dir(MyFile) <> "" Then
ActiveSheet.OLEObjects("CheckBox" & i). _
Object.Value = True ' <~~~~~~~~~~~~~~~~ Error occurs here
With ActiveSheet.Cells(d, "F")
.Value = Now
.NumberFormat = "dd/mm/yy"
'If (ActiveSheet.Cells(d, "F") - ActiveSheet.Cells(d, "G") >= 0) Then
' ActiveSheet.Cells(d, "F").Font.Color = vbRed
'End If
If (.Value - .Offset(0, 1).Value) >= 0 Then
.Font.Color = vbRed
Else
.Font.Color = vbBlack
End If
End With
' i = i + 1
'd = d + 1
End If
End If
Next
End Sub
The program terminates after stepping into this line of code:
ActiveSheet.OLEObjects("CheckBox" & i). _ Object.Value = True
OLEObject does not have a member called value. If you are trying to display the OLEObject, use visible instead
ActiveSheet.OLEObjects("CheckBox" & i).Visible = True
See all OLEObject members here :
OLEObject Object Members