I'm trying this, but it's not working:
Sub macro1()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Dim LR As Long
With ActiveSheet
LR = .Cells(.Rows.Count, "C").End(xlUp).Row
End With
For r = 2 To LR
p = Application.Match(Cells(r, 3), Sheets("Input").Range("C:C"), 0)
If IsError(p) Then GoTo nextr:
Cells(r, 4).Value = .Value & ",newsletter" '***here***
nextr:
Next r
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
If I use the following on the line marked here :
Cells(r,4) = "Y"
It works, so I guess I've done my append wrong?
Just to spell out the answer and to format it nicely:
Option Explicit
Sub macro1()
Dim p As Double
Dim LR As Long
Dim r As Long
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
LR = ActiveSheet.Cells(ActiveSheet.Rows.Count, "C").End(xlUp).Row
For r = 2 To LR
p = Application.Match(Cells(r, 3), Sheets("Input").Range("C:C"), 0)
If Not IsError(p) Then
ActiveSheet.Cells(r, 4).Value = ActiveSheet.Cells(r, 4).Value & ",newsletter" '***here***
End If
Next r
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
Related
My code is to reference a named range(Pump Number), find the last instance in a table(another sheet), copy the row it was found in and paste that data in the new row that was created in the table. It is then to loop trough a series of cells on another sheet and find true values. If the value is true it is to copy another named range(Hours) and paste that value into the table in the correct column. The code executes correctly in debug, stepping through one line at a time, but when ran normally, it does not copy the last line of data in the table and paste the values in the new row. The code where it does not work properly starts at line 90
Sub SavePumpMaintenance()
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Dim tbla As ListObject, last_row, total_stage As Integer
Dim issue, pump, pump_hrs, main_date, main_code As String
Dim correct_plunger, correct_part As Boolean, Data As Worksheet
Dim Maint As Worksheet, wSheet As Worksheet, r As Long
Dim tbl As ListObject, newrow As ListRow, i As Long
Dim cells As Range, LR As Integer, Hist As Worksheet
Set Hist = Sheet26
Set CurrentHours = Range("CurrentHours")
Set tbl = Hist.ListObjects("Historical")
Set newrow = tbl.ListRows.Add
Set Data = Sheet5
Set Maint = Sheet3
Set tbla = Maint.ListObjects("MaintPerformed")
correct_plunger = Data.Range("N6").Value
correct_part = Data.Range("N10").Value
main_code = Data.Range("Y8").Value
issue = Data.Range("Y11").Value
last_row = Data.Range("N11").Value
pump = Maint.Range("C6").Value
pump_hrs = Maint.Range("C7").Value
main_date = Maint.Range("C8").Value
total_stage = Maint.Range("C9").Value
LR = tbl.Range(Rows.Count).End(xlUp).Row
'Unprotect all sheets
For Each wSheet In Worksheets
wSheet.Unprotect Password:="SomePassword"
Next wSheet
If pump = "" Then
MsgBox "Please select a pump."
Application.Calculation = xlCalculationAutomatic
Exit Sub
End If
If pump_hrs = "" Then
MsgBox "Please enter hours."
Application.Calculation = xlCalculationAutomatic
Exit Sub
End If
If Range("Date") = "" Then
MsgBox "Please enter date and time of maintenance."
Application.Calculation = xlCalculationAutomatic
Exit Sub
End If
If correct_plunger = False Then
MsgBox "Incorrect plunger type selected"
Application.Calculation = xlCalculationAutomatic
Exit Sub
End If
If correct_part = False Then
MsgBox "Incorrect part type selected"
Application.Calculation = xlCalculationAutomatic
Exit Sub
End If
Data.Range("T3:T37").Copy 'Copy used parts/pump info to maintenance table
Maint.Range("O1").Offset(last_row,0).PasteSpecial xlValues,Transpose:=True
Data.Range("U3:U12").Copy
Maint.Range("BJ1").Offset(last_row,0).PasteSpecial xlValues,Transpose:=True
Maint.Range("J1").Offset(last_row, 0).Value = pump
Maint.Range("J1").Offset(last_row, 1).Value = pump_hrs
Maint.Range("J1").Offset(last_row, 2).Value = total_stage
Maint.Range("J1").Offset(last_row, 3).Value = main_date
Maint.Range("J1").Offset(last_row, 4).Value = main_code
Maint.Range("J1").Offset(last_row, 63).Value = issue
'Copy last set of historical data for pump 'add maintenance to history
For r = 1 To LR Step 1
If tbl.Range(r, 1).Value = Range("Pumpnumber") Then
Range("H" & r & ":V" & r).Copy
newrow.Range(8).PasteSpecial Paste:=xlValues
End If
Next r
With newrow 'Paste current pump information
.Range(1) = Range("Pumpnumber")
.Range(2) = Range("Date")
.Range(3) = CurrentHours
.Range(4) = Range("Position")
.Range(5) = Range("Fleet")
.Range(6) = Range("WFNumb")
.Range(7) = Range("OStage")
End With
'copy hours from maintenance if checked into maint. history
For i = 1 To 5
If Maint.cells(13, i + 2).Value = True Then
CurrentHours.Copy
newrow.Range(7 + i).PasteSpecial xlPasteValues
End If
If Maint.cells(16, i + 2).Value = True Then
CurrentHours.Copy
newrow.Range(12 + i).PasteSpecial xlPasteValues
End If
If Maint.cells(21, i + 2).Value = True Then
CurrentHours.Copy
newrow.Range(17 + i).PasteSpecial xlPasteValues
End If
If Maint.cells(22, i + 2).Value = True Then
CurrentHours.Copy
newrow.Range(17 + i).PasteSpecial xlPasteValues
End If
Next i
Application.CutCopyMode = False
Dim mp As Range, P As Range 'Copy Current hrs to Equipment Sheet
Set mp = Range("MyPumps")
For Each P In mp
If P.Value = Range("PumpNumber") Then
P.Offset(0, 5).Value = Range("CurrentHours")
End If
Next P
Sheet3.Protect Password:="MyPassword" 'Protect sheets
Sheet5.Protect Password:="MyPassword"
Sheet16.Protect Password:="MyPassword"
Sheet25.Protect Password:="MyPassword"
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
I'm using below code in vba but it taking too much time to run. Report have 8 sheets and 450+ rows should be check in each sheet.
Sub forloop()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.Calculation = xlCalculationManual
lr = Cells(Rows.Count, 3).End(xlUp).Row - 1
For s = 1 To Sheets.Count
For x = lr To 1 Step -1
If Cells(x, 2) <> "" Then
Cells(x, 2).EntireRow.Delete
Next x
Next s
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.Calculation = xlCalculationAutomatic
End Sub
Could you please suggest me any alternate method to run fast.
dim wb as workbook, sht as worksheet, lr as long, r as long
set wb = workbook.open(wbPathHere)
for each sht in wb.worksheets
lr = sht.cells(sht.rows.count, 3).End(xlUp).row - 1
for r = lr to 1 step-1
if sht.cells(r, 2) <> "" Then sht.cells(r, 2).entirerow.delete
next r
next sht
I have the following data in Excel:
1.07 ± 0.35^a 1.21 ± 0.13^a 0.67 ± 0.31^a 1.43 ± 0.05^a
I am looking for a macro to change the text after the ^ symbol to superscript, whilst also removing the ^ symbol. I thought I had found the answer from this site http://www.beingbrunel.com/inline-subsuper-script-in-excel-and-more/, but I can't get the add-in to work.
This is my attempted code, but no cigar.
Sub Loop_Exampl()
Dim Firstrow As Long
Dim Lastrow As Long
Dim Lrow As Long
Dim CalcMode As Long
Dim ViewMode As Long
With Application
CalcMode = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With
'We use the ActiveSheet but you can replace this with
'Sheets("MySheet")if you want
With ActiveSheet
'We select the sheet so we can change the window view
.Select
'If you are in Page Break Preview Or Page Layout view go
'back to normal view, we do this for speed
ViewMode = ActiveWindow.View
ActiveWindow.View = xlNormalView
'Turn off Page Breaks, we do this for speed
.DisplayPageBreaks = False
'Set the first and last row to loop through
Firstrow = .UsedRange.Cells(1).Row
Lastrow = .UsedRange.Rows(.UsedRange.Rows.Count).Row
'We loop from Lastrow to Firstrow (bottom to top)
For Lrow = Lastrow To Firstrow Step -1
'We check the values in the A column in this example
With .Cells(Lrow, "B")
With ActiveCell.Characters(Start:=2, Length:=1).Font
.Superscript = False
.Subscript = True
End With
End Sub
Not sure how you'd do this without the ^ Maybe superscript every letter which directly c=follows a digit ?
Sub tester()
Dim c As Range
For Each c In Selection.Cells
SuperIt c
Next c
End Sub
Sub SuperIt(rng As Range)
Dim s, p, e
s = rng.Text
p = InStr(s, "^")
If p > 0 Then
Do
e = 1
Do While Mid(s, p + e, 1) <> " " And p + e < Len(s)
e = e + 1
Loop
rng.Characters(p, 1).Delete
rng.Characters(p, e).Font.Superscript = True
s = rng.Text
p = InStr(s, "^")
Loop While p > 0
End If
End Sub
This code will create superscripts of letters in the selected range, meaning that the ^ symbol is not required.
Sub FixFormatting()
Dim c As Range
Dim StartCells As Range
Dim ws As Worksheet
Dim intPlace As Integer
Dim wsStartsProtected As Boolean
Application.ScreenUpdating = False
On Error GoTo errorCatch
Set StartCells = Selection
For Each c In Selection.Cells
With c
.Replace What:="a", Replacement:="a", LookAt:=xlPart, MatchCase:=False
.Replace What:="b", Replacement:="b", LookAt:=xlPart, MatchCase:=False
.Replace What:="c", Replacement:="c", LookAt:=xlPart, MatchCase:=False
End With
intPlace = InStr(c.Value, "a")
If intPlace > 0 Then
If ActiveSheet.ProtectContents = True Then ActiveSheet.Unprotect
c.Characters(intPlace, 1).Font.Superscript = True
End If
intPlace = InStr(c.Value, "b")
If intPlace > 0 Then
If ActiveSheet.ProtectContents = True Then ActiveSheet.Unprotect
c.Characters(intPlace, 1).Font.Superscript = True
End If
intPlace = InStr(c.Value, "c")
If intPlace > 0 Then
If ActiveSheet.ProtectContents = True Then ActiveSheet.Unprotect
c.Characters(intPlace, 1).Font.Superscript = True
End If
If wsStartsProtected Then ws.Protect
Next
StartCells.Parent.Activate
StartCells.Select
Application.ScreenUpdating = True
Exit Sub
errorCatch:
If wsStartsProtected Then ws.Protect
StartCells.Parent.Activate
StartCells.Select
Application.ScreenUpdating = True
End Sub
I am trying to add and copy a formula across a range of cells and then paste the values. Currently, the code I have works, BUT it takes too long to run. Do you know of a more efficient way to accomplish my goal? I am pasting the formula across 77,000 cells in ~3.69 minutes.
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.EnableEvents = False
Dim ws As Worksheet, Lastrow As Long
Set ws = Sheets("Sheet1")
With ws
Lastrow = ws.Range("A" & Rows.Count).End(xlUp).Row
.Range("CS1").Value = "Actual Bonus - Amount"
.Range("CS2").Formula = "=SUMIF(Table7[ID],table3[ID],Table7[Actual])"
.Range("CS2").Copy
.Range("CS3:CS" & Lastrow).PasteSpecial xlPasteFormulas
End With
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.EnableEvents = True
End Sub
Thank you!
You can use .FillDown to put the formulas into the cells below without having to copy/paste.
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.EnableEvents = False
Dim ws As Worksheet, Lastrow As Long
Set ws = Sheets("Sheet1")
With ws
Lastrow = ws.Range("A" & Rows.Count).End(xlUp).Row
.Range("CS1").Value = "Actual Bonus - Amount"
.Range("CS2").Formula = "=SUMIF(Table7[ID],table3[ID],Table7[Actual])"
.Range("CS2:CS" & Lastrow).FillDown
End With
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.EnableEvents = True
End Sub
I have an Excel sheet with the following structure:
What I need to do is delete an entire record if either it's Type A or Type B are = 0. As an example, for record 1, I need to delete A & B because B = 0.
I have the following code:
Sub Loop_Example()
Dim Firstrow As Long
Dim Lastrow As Long
Dim Lrow As Long
Dim CalcMode As Long
Dim ViewMode As Long
With Application
CalcMode = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With
With ActiveSheet
.Select
ViewMode = ActiveWindow.View
ActiveWindow.View = xlNormalView
.DisplayPageBreaks = False
Firstrow = .UsedRange.Cells(1).Row
Lastrow = .UsedRange.Rows(.UsedRange.Rows.Count).Row
For Lrow = Lastrow To Firstrow Step -1
With .Cells(Lrow, "B")
If Not IsError(.Value) Then
If .Value = "0" Then .EntireRow.Delete
End If
End With
Next Lrow
End With
ActiveWindow.View = ViewMode
With Application
.ScreenUpdating = True
.Calculation = CalcMode
End With
End Sub
Therefore, what I would like to do is add the logic to delete the entire row if the value is 0 and either the row above or below depending on its 'type'.
Thanks.
this should work.
Sub pDeleteRow()
Dim wksData As Worksheet
Dim rngCell As Range
Dim lngCounter As Long
Dim lngTotalCount As Long
Set wksData = Worksheets("Sheet1")
lngTotalCount = wksData.Range("A1").CurrentRegion.Rows.Count
lngCounter = 1
With wksData
While lngCounter <= lngTotalCount
If (UCase(Trim(.Cells(lngCounter, 2))) = "A" Or UCase(Trim(.Cells(lngCounter, 2))) = "B") And UCase(Trim(.Cells(lngCounter, 3))) = "0" Then
.Cells(lngCounter, 1).EntireRow.Delete
lngCounter = lngCounter - 1
lngTotalCount = lngTotalCount - 1
End If
lngCounter = lngCounter + 1
Wend
End With
End Sub
You can Try This:
Sub ConditionalRowDelete()
Set colA = Range("C1", Cells(Rows.Count, "C").End(xlUp))
Set colB = Range("D1", Cells(Rows.Count, "D").End(xlUp))
MsgBox colA.Rows.Count
For i = 1 To colA.Rows.Count
If colB(i) = 0 Then
If colA(i) = "A" Then
'colB(i).Select
With colB(i) 'Selection
Application.Union(.EntireRow, .Offset(1, 0).EntireRow).Delete 'Select
End With
'Selection.EntireRow.Select
'MsgBox "found A"
End If
If colA(i) = "B" Then
'colB(i).Select
With colB(i) 'Selection
Application.Union(.EntireRow, .Offset(-1, 0).EntireRow).Delete 'Select
End With
'MsgBox "found B"
End If
End If
Next
End Sub