I'm trying to get a loop with multiple if/else statements to work but it keeps saying either I have Ifs with no End Ifs or that I have a Loop with no Do.
Any pointers would be great.
Below is the what I've done so far, please go easy on me I only started trying to write in vba yesterday...
Sub EditTransposeCopy()
Sheets("Altered").Select
Dim count As Long
count = WorksheetFunction.CountA(Range("A6", Range("A6").End(xlDown))) - 1
Do While count > 0
If InStr(1, (Range("A23").Value), "Reason:") > 0 Then
Rows("9:11").Select
Application.CutCopyMode = False
Selection.Delete Shift:=xlUp
Rows("14").Select
Application.CutCopyMode = False
Selection.Delete Shift:=xlUp
Rows("16").Select
Application.CutCopyMode = False
Selection.Delete Shift:=xlUp
Rows("18").Select
Application.CutCopyMode = False
Selection.Delete Shift:=xlUp
Range("A7:A18").Select
Selection.Copy
Range("C6").Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True
Range("A6:N6").Copy
Sheets("Output").Range("A" & Rows.count).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
Sheets("Altered").Select
Rows("6:18").Select
Application.CutCopyMode = False
Selection.Delete Shift:=xlUp
count = count - 19
Else
If InStr(1, (Range("A20").Value), "Reason:") > 0 Then
Rows("9:11").Select
Application.CutCopyMode = False
Selection.Delete Shift:=xlUp
Rows("14").Select
Application.CutCopyMode = False
Selection.Delete Shift:=xlUp
Rows("16").Select
Application.CutCopyMode = False
Selection.Delete Shift:=xlUp
Range("A7:A16").Select
Selection.Copy
Range("C6").Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True
Range("A6:L6").Copy
Sheets("Output").Range("A" & Rows.count).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
Sheets("Altered").Select
Rows("6:16").Select
Application.CutCopyMode = False
Selection.Delete Shift:=xlUp
count = count - 16
Else
If InStr(1, (Range("A17").Value), "Reason:") > 0 Then
Rows("9:11").Select
Application.CutCopyMode = False
Selection.Delete Shift:=xlUp
Rows("14").Select
Application.CutCopyMode = False
Selection.Delete Shift:=xlUp
Range("A7:A14").Select
Selection.Copy
Range("C6").Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True
Range("A6:J6").Copy
Sheets("Output").Range("A" & Rows.count).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
Sheets("Altered").Select
Rows("6:14").Select
Application.CutCopyMode = False
Selection.Delete Shift:=xlUp
count = count - 13
Else
If InStr(1, (Range("A15").Value), "£0.00") > 0 Then
Sheets("Altered").Select
Rows("9:11").Select
Application.CutCopyMode = False
Selection.Delete Shift:=xlUp
Range("A7:A12").Select
Selection.Copy
Range("C6").Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True
Range("A6:H6").Copy
Sheets("Output").Range("A" & Rows.count).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
Sheets("Altered").Select
Rows("6:12").Select
Application.CutCopyMode = False
Selection.Delete Shift:=xlUp
count = count - 10
Else
count = count - 10000000
End If
Loop
'
End Sub
Thanks in advance
Use ElseIf or terminate each If block with an End If
Sub EditTransposeCopy()
'...
Do While count > 0
If InStr(1, (Range("A23").Value), "Reason:") > 0 Then
'...
ElseIf InStr(1, (Range("A20").Value), "Reason:") > 0 Then
'...
ElseIf InStr(1, (Range("A15").Value), "£0.00") > 0 Then
'...
Else
'...
End If
Loop
End Sub
Welcome to SO, and welcome to VBA!
First up, you should look at how to avoid using select, because although this is how the macro recorder works, it's better practice (less prone to bugs) and more readable if you replace code like
Range("A1").Select
Selection.Copy
with
Range("A1").Copy
Secondly look up the syntax of an if statement - in particular this part about use of Else If will be handy in the above code. Each If requires it's own End If, looks like you missed a couple in your original code.
Related
I have a macro that performs some cleanup on values. It works fine unless there is only one row of data in the spreadsheet; if there is only one row, it blanks out my value instead of fixing it.
Sub UpdateNumberFormat()
Dim LastRow As Long
LastRow = Cells(Rows.Count, 1).End(xlUp).Row
Columns("AL:AM").Select
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Selection.NumberFormat = "General"
Range("AL2").Select
ActiveCell.FormulaR1C1 = "'"
Range("AM2").Select
ActiveCell.FormulaR1C1 = "=CONCAT(RC[-1],RC[1])"
Range("AL2:AM" & LastRow).Select
Selection.FillDown
Range("AM2:AM" & LastRow).Select
Selection.Copy
Range("AN2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Columns("AL:AM").Select
Application.CutCopyMode = False
Selection.Delete Shift:=xlToLeft
Range("A1").Select
Columns("C:C").Select
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Selection.NumberFormat = "General"
Range("C2").Select
ActiveCell.FormulaR1C1 = "=TRIM(RC[-1])"
Range("C2:C" & LastRow).Select
Selection.FillDown
Selection.Copy
Range("B2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Columns("C:C").Select
Application.CutCopyMode = False
Selection.Delete Shift:=xlToLeft
Range("A1").Select
End Sub
I have created a simple macro to cut and paste data from one sheet to another and every once in a while I will get the Run time error 1004 cannot paste data error. It doesn't do it all the time.
Here is my current code:
Sub INSERTVE()
'
' INSERTVE Macro
'
' Keyboard Shortcut: Ctrl+Shift+I
'
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Application.DisplayStatusBar = False
ActiveSheet.DisplayPageBreaks = False
Application.ScreenUpdating = False
ActiveWorkbook.Names.Add Name:="newrowa", RefersToR1C1:=Rows(ActiveCell.Row)
Application.Goto Reference:="newrowa"
Application.Goto Reference:="NEWTRENDLOGITEM"
Selection.Copy
Application.Goto Reference:="newrowa"
Selection.EntireRow.Insert
Range("newrowa").Select
ActiveCell.Rows("1:1").EntireRow.Select
Application.Goto Reference:="insertsection"
Selection.Copy
Application.Goto Reference:="LASTROW"
Selection.EntireRow.Insert
ActiveWorkbook.Names.Add Name:="newrowZ", RefersToR1C1:=Rows(ActiveCell.Row)
Range("newrowZ").Select
ActiveWorkbook.Names("newrowZ").Delete
ActiveCell.Rows("1:1").EntireRow.Select
ActiveWorkbook.Names.Add Name:="newrowZ", RefersToR1C1:=Rows(ActiveCell.Row)
ActiveCell.Rows("1:1").EntireRow.Select
ActiveCell.Offset(0, 8).Range("A1").Select
Sheets("ve-01").Select
Application.Goto Reference:="newrowa"
ActiveCell.Rows("1:1").EntireRow.Select
ActiveCell.Offset(-1, 2).Range("A1").Select
Selection.Copy
Application.Goto Reference:="LASTROW"
ActiveCell.Offset(-13, 2).Range("A1").Select
**ActiveSheet.Paste link:=True**
Application.Goto Reference:="newrowa"
ActiveCell.Offset(-1, 3).Range("A1").Select
Selection.Copy
Application.Goto Reference:="LASTROW"
ActiveCell.Offset(-13, 3).Range("A1").Select
ActiveSheet.Paste link:=True
Application.Goto Reference:="LASTROW"
ActiveCell.Offset(-2, 16).Range("A1").Select
Selection.Copy
Application.Goto Reference:="newrowa"
ActiveCell.Rows("1:1").EntireRow.Select
ActiveCell.Offset(-1, 13).Range("A1").Select
ActiveSheet.Paste link:=True
Application.Goto Reference:="newrowa"
ActiveCell.Rows("1:1").EntireRow.Select
ActiveCell.Offset(-1, 1).Range("A1").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("VE-01").Select
Range("newrowa").Select
ActiveWorkbook.Names("newrowa").Delete
ActiveWorkbook.Names("newrowz").Delete
Application.CutCopyMode = False
Application.ScreenUpdating = True
Application.DisplayStatusBar = True
ActiveSheet.DisplayPageBreaks = True
Application.Calculation = xlCalculationAutomatic
End Sub
Any suggestions or ideas on why it only does this once in a while? Any tips for a newbie on how to correct this? The code errors out when it gets to ActiveSheet.Paste link:=True
Thanks,
I have a workbook that refreshes data connections, then filters dates from yesterday. When there is only one row that is refreshed, I will get a
Run time error 1004.
Some days the macro works, some days it doesn't. This is run daily.
Sub Get_VRIDs()
Dim i As Integer
Sheets("Cancels").Select
i = 1
With Range("E2")
If .Cells(1, 1).Value = "" Then
Else
Range(.Cells(1, 1), .End(xlDown)).Copy
Destination:=Sheets("Metric").Range("a6")
x = x + 1
End If
End With
Sheets("Adhoc").Select
i = 1
With Range("C2")
If .Cells(1, 1).Value = "" Then
Else
Range(.Cells(1, 1), .End(xlDown)).Copy Destination:=Sheets("Metric").Range("a94")
x = x + 1
End If
End With
Sheets("Direct Tender").Select
i = 1
With Range("B2")
If .Cells(1, 1).Value = "" Then
Else
Range(.Cells(1, 1), .End(xlDown)).Copy Destination:=Sheets("Metric").Range("a132")
x = x + 1
Sheets("Metric").Activate
End If
End With
Sheet1.Activate
Range("B6").Select
Selection.Copy
Range("A6:A90").Select
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
ActiveWindow.SmallScroll Down:=48
Range("B60").Select
Selection.Copy
Range("A94:A128").Select
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
ActiveWindow.SmallScroll Down:=24
Range("B90").Select
Selection.Copy
Range("A132:A200").Select
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
ActiveWindow.SmallScroll Down:=-108
Range("A7").Select
Call Hide_Rows
End Sub
The error occurs at this line:
Range(.Cells(1, 1), .End(xlDown)).Copy Destination:=Sheets("Metric").Range("a94")
I have nested "Do While" loops near the bottom of the below code that are not incrementing. I have stepped through the code, and confirmed that once a non-zero value is found in cell E37 of the "Outages" tab, the code continuously finds a solution for that value instead of incrementing the company code. The company and trading partner numbers are in a matrix from B2:AE31. This is an accounting application to figure out which intercompany accounts do not balance by company and trading partner. Basically, this macro needs to loop through all combination of values for company code and trading partner (1:27 for each). Any help you can give would be appreciated.
'4 - Identify outages in table (loop through)
Dim i As Integer
Dim j As Integer
Dim CO As String
Dim TP As String
Dim MO As Integer
Dim SolverValue As Double
i = 1 'Company code
j = 1 'Trading partner
MO = Sheets("Inputs").Range("B1").Value2
Do While i < 28
Range("E34").Value2 = i
j = 1
Do While j < 28
Range("E35").Value2 = j
Sheets("Outages").Select
If Range("E37").Value2 <> 0 Then
CO = Range("E34").Value2
TP = Range("E35").Value2
'4a - Run solver for companies if an outage is found
ThisWorkbook.Sheets.Add After:=Sheets(Sheets.Count)
ActiveSheet.Name = "Solver"
Sheets("Transactions").Select
Cells.Select
Selection.AutoFilter
ActiveSheet.Range("$A$1:$R$10000").AutoFilter Field:=2, Criteria1:=MO
ActiveSheet.Range("$A$1:$R$10000").AutoFilter Field:=9, Criteria1:=CO, _
Operator:=xlOr, Criteria2:=TP
ActiveSheet.Range("$A$1:$R$10000").AutoFilter Field:=11, Criteria1:=CO, _
Operator:=xlOr, Criteria2:=TP
ActiveSheet.Range("$A$1:$R$10000").AutoFilter Field:=18, Criteria1:="1"
Sheets("Transactions").Select
Rows("1:10000").Select
Selection.Copy
Sheets("Solver").Select
Rows("1:1").Select
ActiveSheet.Paste
Columns("A:A").EntireColumn.AutoFit
Cells.Select
Cells.EntireColumn.AutoFit
Range("Q1").Select
Application.CutCopyMode = False
ActiveCell.FormulaR1C1 = "=+SUM(R[1]C:R[201]C)"
Range("Q2").Select
ActiveWindow.SmallScroll Down:=-18
ActiveCell.FormulaR1C1 = "=+RC[-3]*RC[-1]"
Range("Q2").Select
Selection.Copy
Range("Q3:Q203").Select
ActiveSheet.Paste
Range("P2").Select
Application.CutCopyMode = False
Selection.Copy
Range("P3:P203").Select
ActiveSheet.Paste
Range("R1").Select
ActiveWindow.SmallScroll ToRight:=4
Sheets("Outages").Select
Range("E37").Select
Selection.Copy
Sheets("Solver").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Selection.Copy
Selection.Style = "Comma"
SolverReset
SolverValue = Sheets("Outages").Range("E37")
SolverOk SetCell:="$Q$1", MaxMinVal:=3, ValueOf:=SolverValue, ByChange:= _
"$P$2:$P$201", Engine:=2, EngineDesc:="Simplex LP"
SolverAdd CellRef:="$P$2:$P$201", Relation:=5, FormulaText:="binary"
SolverSolve True
Columns("P:R").Select
Columns("P:R").EntireColumn.AutoFit
'4b - Copy entries causing outages to a list
Cells.Select
Selection.AutoFilter
ActiveSheet.Range("$A$1:$W$201").AutoFilter Field:=16, Criteria1:="1.00"
Range("A2:Q1000").Select
Selection.Copy
Sheets("Transactions Causing Outages").Select
Range("A2").Select
ActiveSheet.Paste
Columns("N:Q").Select
Application.CutCopyMode = False
Selection.Delete Shift:=xlToLeft
Cells.Select
Cells.EntireColumn.AutoFit
'4c - Delete Solver tab
Application.DisplayAlerts = False
Worksheets("Solver").Delete
Application.DisplayAlerts = True
Worksheets("Transactions").ShowAllData 'Unfilter the transactions tab
End If
j = j + 1
Loop
i = i + 1
Loop
Sheets("Outages").Select was out of place.
I'm trying to copy and past transpose and there is many rows.
The following code get from record macro, how to create loop upto L1000:N1000 in sheet2?
Sub Macro4()
Sheets("sheet2").Select
Range("L5:N5").Select
Selection.Copy
Sheets("Sheet1").Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True
Sheets("sheet2").Select
Range("L6:N6").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Sheet1").Select
Range("B14").Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True
Sheets("sheet2").Select
Range("L7:N7").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Sheet1").Select
ActiveWindow.SmallScroll Down:=6
Range("B24").Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True
End Sub
Since you are copying across as Paste Special Paste:=xlPasteAll, Transpose:=True, I retained that to keep your formulas and formatting. If only values were desired to be brought across in a transposed array, there are other methods that would be faster.
This starts with the destination as B4 and adds 10 rows to each successive loop; e.g. B4, B14, B24, etc.
Sub Copy_From_WS1_to_WS2_by_10()
Dim rw As Long
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
With Sheets("Sheet1")
For rw = 4 To 1000
.Cells(rw, 12).Resize(1, 3).Copy
Sheets("Sheet2").Cells(4 + (rw - 4) * 10, 2).PasteSpecial _
Paste:=xlPasteAll, Transpose:=True, Operation:=xlNone, SkipBlanks:=False
Application.CutCopyMode = False
Next rw
End With
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
I've returned the calculation mode to Automatic at the end of the macro. Remove or comment that line if you wish it to remain manual.