I am running this macro:
Sub Check()
ActiveSheet.EnableCalculation = False
Application.ScreenUpdating = False
Application.DisplayStatusBar = False
Application.EnableEvents = False
ActiveSheet.DisplayPageBreaks = False
If Sheets(1).Range("A1").Value = "Enter Data" Then
Sheets(2).Activate
Else
If Sheets(1).Range("H10").Value <> "" And Sheets(1).Range("I10").Value <> "" And Sheets(1).Range("J10").Value <> "" Then
Dim lastRow As Long
Dim sht1 As Worksheet
Dim sht2 As Worksheet
Set sht1 = Sheets(2)
If sht1.Range("A1").Value <> "" Then
'insert column b formula
lastRow = sht1.Range("A" & Rows.Count).End(xlUp).Row
sht1.Range("B2").Formula = "=MID(A2, 1, 12)"
sht1.Range("B2").AutoFill Destination:=sht1.Range("B2:B" & lastRow)
'insert column c formula
sht1.Range("C2").Formula = "=--LEFT(B2,4)"
sht1.Range("C2").AutoFill Destination:=sht1.Range("C2:C" & lastRow)
'insert column d formula
sht1.Range("D2").Formula = "=--RIGHT(MID(A2, 14, 7),LEN(MID(A2, 14, 7))-FIND(LEFT(SUBSTITUTE(MID(A2, 14, 7)&"" "",""0"",""""),1),MID(A2, 14, 7)&"" "")+1)"
sht1.Range("D2").AutoFill Destination:=sht1.Range("D2:D" & lastRow)
'insert column E formula
sht1.Range("E2").Formula = "=DATE(""20""&MID(B2,9,2),MID(B2,7,2),MID(B2,5,2))"
sht1.Range("E2").AutoFill Destination:=sht1.Range("E2:E" & lastRow)
'insert column F formula
sht1.Range("F2").Formula = "=IF(E2<>"""",WEEKNUM(E2,21),"""")"
sht1.Range("F2").AutoFill Destination:=sht1.Range("F2:F" & lastRow)
'insert column G formula
sht1.Range("G2").Formula = "=SUBSTITUTE(TRIM(MID(A2, FIND(""-"", A2, FIND(""-"", A2)+9)+9,256)),"" "","" / "")"
sht1.Range("G2").AutoFill Destination:=sht1.Range("G2:G" & lastRow)
Else
MsgBox "Please First Copy and Paste Estimated Receivings."
End If
Set sht2 = Sheets(1)
With sht2
If Range("H10").Value <> "" Then
lastRow = .Cells(.Rows.Count, 10).End(xlUp).Row
.Range("K10").FormulaArray = "=IFERROR(INDEX(Data!$G:$G,MATCH(1,(Home!$H10=Data!$C:$C)*(Home!$I10=Data!$D:$D)*(IF(Home!$J10<55,Home!$J10,WEEKNUM(Home!$J10,21))=Data!$F:$F),0)),"""")"
If lastRow <> 10 Then
.Range("K10").AutoFill ActiveSheet.Range("K10:K" & lastRow)
End If
.Range("M10").FormulaArray = "=IFERROR(INDEX(Data!$B:$B,MATCH(1,(Home!$H10=Data!$C:$C)*(Home!$I10=Data!$D:$D)*(IF(Home!$J10<55,Home!$J10,WEEKNUM(Home!$J10,21))=Data!$F:$F),0)),""No Po Found"")"
If lastRow <> 10 Then
.Range("M10").AutoFill ActiveSheet.Range("M10:M" & lastRow)
End If
.Range("L10").FormulaArray = "=IFERROR(INDEX(Data!$F:$F,MATCH(1,(Home!$H10=Data!$C:$C)*(Home!$I10=Data!$D:$D)*(IF(Home!$J10<55,Home!$J10,WEEKNUM(Home!$J10,21))=Data!$F:$F),0)),"""")"
If lastRow <> 10 Then
.Range("L10").AutoFill ActiveSheet.Range("L10:L" & lastRow)
End If
Else
MsgBox "Please enter some data."
End If
End With
Else
MsgBox "At Least One Order Must Be Checked."
End If
End If
Application.ScreenUpdating = True
Application.DisplayStatusBar = True
Application.EnableEvents = True
ActiveSheet.DisplayPageBreaks = True
ActiveSheet.EnableCalculation = True
End Sub
For some reason, when the code has finished running, my excel sheet displays three segregated lines like this:
Why is this, and how can i remove them? I appreciate any help. Thanks
I think you should remove
ActiveSheet.DisplayPageBreaks = True
Related
My code doesn't recognize cell values as equal to listbox items even though it is. Everything works perfectly until it begins the loop, where it then doesn't consider SelItem the same value as the cell value. I ran the loop seperately without it being part of the Userform sub and here it works fine.
I looked up in Locals window and the SelItem is a Variant/String variable and I guess it should be compatible with a cell value?
Please see code below.
Sub CommandButton3_Click()
Dim SelectedItems As String, LastRow As Long
Dim selItem As Variant, selItems As Variant
For i = 0 To CountryList.ListCount - 1
If CountryList.Selected(i) = True Then
SelectedItems = SelectedItems & CountryList.List(i) & vbNewLine
End If
Next i
If SelectedItems = "" Then
MsgBox "Please select minimum one country"
Else
CountrySelection.Hide
'Create New Sheet
Set WS = Sheets.Add(after:=Sheets(Worksheets.Count))
WS.Name = "Country Selection"
'If Sheet is VeryHidden
Dim WasHidden
Application.ScreenUpdating = False
If Sheets("Country Split").Visible = xlSheetVeryHidden Then
Sheets("Country Split").Visible = xlSheetVisible
WasHidden = True
End If
Sheets("Country Split").Select
Cells.Select
Selection.Copy
Sheets("Country Selection").Select
Range("A1").Select
ActiveSheet.Paste
'Format As Table
Set StartCell = Range("D10")
StartCell.CurrentRegion.Select
ActiveSheet.ListObjects.Add(xlSrcRange, , , xlYes).Name = _
"Country_Selection"
producttable = ActiveSheet.ListObjects("Country_Selection")
If WasHidden Then Sheets("Country Split").Visible = xlSheetVeryHidden
LastRow = ActiveSheet.Range("F1").SpecialCells(xlCellTypeLastCell).Row
SelectedItems = Left(SelectedItems, Len(SelectedItems) - 1)
selItems = Split(SelectedItems, vbNewLine)
This is where it read If Range("F" & i).Value = selItem as not the same thing even though it is.
For Each selItem In selItems
For i = 11 To LastRow
If Range("F" & i).Value = selItem Then Rows(i).Hidden = True
Next i
Next
End If
For i = 11 To LastRow
If Rows(i).Hidden = True Then Rows(i).EntireRow.Delete
Next
Unload CountrySelection
End Sub
I need to have this code look from the bottom up and once it reaches a cell in Column G that is populated it stops deleting lines. Can some one help me out. There will be blanks in column G but, I just need it to look from the bottom up to the last populated cell in column G and delete everything below that.
Routine to Delete Blank Lines to the Datasheet, Uncertainty and Repeatability Sheets
Public Sub DeleteBlankLines()
' Declaring the variables
Dim WS As Worksheet
Dim UncWs As Worksheet, RepWs As Worksheet, ImpWs As Worksheet
Dim StopAtData As Boolean
Dim UserAnswer As Variant
Dim rngDelete As Range, UncDelete As Range, RepDelete As Range, ImpDelete As Range
Dim RowDeleteCount As Integer
'Set Worksheets
Set UncWs = ThisWorkbook.Sheets("Uncertainty")
Set RepWs = ThisWorkbook.Sheets("Repeatability")
Set WS = ThisWorkbook.Sheets("Datasheet")
Set ImpWs = ThisWorkbook.Sheets("Import Map")
'Set Delete Variables to Nothing
Set rngDelete = Nothing
Set UncDelete = Nothing
Set RepDelete = Nothing
Set ImpDelete = Nothing
RowDeleteCount = 0
'Determine which cells to delete
UserAnswer = MsgBox("Do you want to delete empty rows " & _
"outside of your data?" & vbNewLine, vbYesNoCancel)
If UserAnswer = vbYes Then
StopAtData = True
'Not needed Turn off at Call in Form
'Application.Calculation = xlCalculationManual
'Application.ScreenUpdating = False
'Application.EnableEvents = False
' Set Range
DS_LastRow = WS.Range("A" & WS.Rows.Count).End(xlUp).Row
For CurrentRow = DS_StartRow To DS_LastRow Step 1
' Delete blank rows by checking the value of cell in column G (Nominal Value)
With WS.Range("G" & CurrentRow & ":O" & CurrentRow)
If WorksheetFunction.CountBlank(.Cells) >= 9 Then
If rngDelete Is Nothing Then
Set rngDelete = WS.Rows(CurrentRow)
Set UncDelete = UncWs.Rows(CurrentRow)
Set RepDelete = RepWs.Rows(CurrentRow)
Set ImpDelete = ImpWs.Rows(CurrentRow)
RowDeleteCount = 1
Else
Set rngDelete = Union(rngDelete, WS.Rows(CurrentRow))
Set UncDelete = Union(UncDelete, UncWs.Rows(CurrentRow))
Set RepDelete = Union(RepDelete, RepWs.Rows(CurrentRow))
Set ImpDelete = Union(ImpDelete, ImpWs.Rows(CurrentRow))
RowDeleteCount = RowDeleteCount + 1
End If
End If
End With
Next CurrentRow
Else
Exit Sub
End If
'Refresh UsedRange (if necessary)
If RowDeleteCount > 0 Then
UserAnswer = MsgBox("This will Delete " & RowDeleteCount & " rows, Do you want to delete empty rows?" & vbNewLine, vbYesNoCancel)
If UserAnswer = vbYes Then
' Delete blank rows
If Not rngDelete Is Nothing Then
UncWs.Unprotect ("$1mco")
RepWs.Unprotect ("$1mco")
rngDelete.EntireRow.Delete Shift:=xlUp
UncDelete.EntireRow.Delete Shift:=xlUp
RepDelete.EntireRow.Delete Shift:=xlUp
ImpDelete.EntireRow.Delete Shift:=xlUp
UncWs.Protect "$1mco", , , , , True, True
RepWs.Protect ("$1mco")
End If
Else
MsgBox "No Rows will be Deleted.", vbInformation, "No Rows Deleted"
End If
Else
MsgBox "No blank rows were found!", vbInformation, "No Blanks Found"
End If
' Set New Last Row Moved to Event
DS_LastRow = WS.Range("A" & WS.Rows.Count).End(xlUp).Row
'Update Line Count on Datasheet
WS.Range("A9").Value = DS_LastRow - DS_StartRow + 1
'Not needed Turn on at Call in Form
'Application.Calculation = xlCalculationAutomatic
'Application.ScreenUpdating = True
'Application.EnableEvents = True
End Sub
Delete Below Last Row
Instead of Delete you can use Clear, or if you want to preserve the formatting below the last row, you can use ClearContents.
The Code
Option Explicit
Sub DelRows()
Const cSheet As Variant = "Sheet1" ' Worksheet Name/Index
Const cColumn As Variant = "G" ' Cirteria Column Letter/Number
Dim lastR As Long ' Last Row
With ThisWorkbook.Worksheets(cSheet)
lastR = .Cells(.Rows.Count, cColumn).End(xlUp).Row
.Range(.Cells(lastR + 1, 1), .Cells(.Rows.Count, 1)).EntireRow.Delete
End With
End Sub
Here is the code that I am using
Sub insert_column_every_other()
Dim colx As Long
Dim H As Worksheet
Set H = Sheets("Sheet1") 'Replace H3 with the sheet that contains your data
For colx = 9 To 1200 Step 2
Call H.Columns(colx).Insert(Shift:=xlToRight)
H.Range(H.Cells(2, colx), H.Cells(21, colx)).FormulaR1C1 = "=
((OFFSET(RC[-1])-(OFFSET(RC[-3]))/(OFFSET(RC[-3]))*SQRT(252))"
Next colx
End Sub
Getting an error in the following line,
H.Range(H.Cells(2, colx), H.Cells(21, colx)).FormulaR1C1 = "=
((OFFSET(RC[-1])-(OFFSET(RC[-3]))/(OFFSET(RC[-3]))*SQRT(252))"
The error is Application-defined error.
The macro will create a column after the 9th column till the 500th column and then in the blank column will calculate the percentage difference of the stock price of two consecutive days so that's why I went with that particular offset formula.
I think this is what you are looking for
Option Explicit
Sub insert_column_every_other()
Dim ws As Worksheet: Set ws = Sheets("Sheet1")
Dim i As Long
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
For i = 9 To 1200 Step 2
ws.Columns(i).Insert
ws.Range(ws.Cells(2, i), ws.Cells(21, i)).Formula = "=(" & ws.Cells(2, i - 1).Address(False, False) & "-" & ws.Cells(2, i - 2).Address(False, False) & ")/(" & ws.Cells(2, i - 2).Address(False, False) & ")*SQRT(252)"
Next i
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
I have below vba code to put a formula in cell AE3 then copy down to last row, i have 5000+ rows but wonder why it take so long to process (about 5 min. and still running), is there a better way to do this? i want copy down to last row as the list is dynamic data with different ranges every day. Thanks.
Sub FillRows()
Dim col_AE As String
Sheet1.Select
col_AE = "=IFERROR(INDEX(setting!C[-17],MATCH(smart!RC[-9],setting!C[-18],0)),"""")"
If col_AE <> vbNullString Then
For j = 3 To Range("A" & Rows.Count).End(xlUp).Row - 1
If Range("ae" & j).Value = vbNullString Then
Range("ae" & j).Value = col_AE
End If
Next j
End If
End Sub
You should turn off both ScreenUpdating and Calculations when working with large numbers of formulas.
This line If col_AE <> vbNullString Then isn't doing anything.
Option Explicit
Sub FillRows()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Dim col_AE As String
With Sheet1
For j = 3 To .Range("A" & .Rows.Count).End(xlUp).Row - 1
If .Range("ae" & j).Value = vbNullString Then
.Range("ae" & j).FormulaR1C1 = "=IFERROR(INDEX(setting!C[-17],MATCH(smart!RC[-9],setting!C[-18],0)),"""")"
End If
Next j
End With
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
The majority of the processing time is being used because the sheet is recalculating every time a formula is added. I would just turn off ScreenUpdating and Calculations and replace all the formulas. In this way I know that the formulas are consistent and that any errors introduced by users would be corrected.
Sub FillRows2()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Dim col_AE As String
With Sheet1
.Range("A3", "A" & .Rows.Count).End(xlUp).FormulaR1C1 = "=IFERROR(INDEX(setting!C[-17],MATCH(smart!RC[-9],setting!C[-18],0)),"""")"
End With
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
This might speed it up - turn off the screen updating while it is running.
Application.ScreenUpdating = False
Application.ScreenUpdating = True
Please try this:
Option Explicit
Sub fillFormula()
Dim wbk1 As Workbook
Dim lastRow As Long
Set wbk1 = ActiveWorkbook
With wbk1.Sheets("sheet1")
lastRow = .Range("A" & .Rows.Count).End(xlUp).Row
lastRow = lastRow - 1
.Range("AE3:AE" & lastRow).Formula = _
"=IFERROR(INDEX(setting!C[-17],MATCH(smart!RC[-9]," _
& "setting!C[-18],0)),"""")"
End With
End Sub
This code works perfectly. I only have one question, I want to make it so that if there is nothing in cell Q23 that it will not put anything into NCMR Data, and say something... the code is below of what I have, and below it is what I think I need to do to a specific section to work, can someone review and make sure I am on the right path?
Option Explicit
Sub NCMR()
Dim i As Integer
With Application
.ScreenUpdating = False
End With
'Internal NCMR
Dim wsInt As Worksheet
Dim wsNDA As Worksheet
'Copy Ranges
Dim c As Variant
'Paste Ranges
Dim P As Range
'Setting Sheet
Set wsInt = Sheets("NCMR Input")
Set wsNDA = Sheets("NCMR Data")
Set P = wsInt.Range("B61:V61")
With wsInt
c = Array(.Range("B11"), .Range("B14"), .Range("B17"), .Range("B20"), .Range("Q23"), .Range("B23") _
, .Range("Q11"), .Range("Q14"), .Range("Q17"), .Range("Q20"), .Range("R26"), .Range("V23") _
, .Range("V25"), .Range("V27"), .Range("B32"), .Range("B40"), .Range("B46"), .Range("B52") _
, .Range("D58"), .Range("L58"), .Range("V58"))
End With
For i = LBound(c) To UBound(c)
P(i + 1).Value = c(i).Value
Next
With wsNDA
Dim LastRow As Long
LastRow = .Range("A" & Rows.Count).End(xlUp).Row + 1
wsInt.Rows("61").Copy
With .Rows(LastRow)
.PasteSpecial Paste:=xlPasteFormats
.PasteSpecial Paste:=xlPasteValues
.Interior.Pattern = xlNone
End With
With .Range("A" & LastRow)
If LastRow = 3 Then
.Value = 1
Else
.Value = Val(wsNDA.Range("A" & LastRow - 1).Value) + 1
End If
.NumberFormat = "0#######"
End With
End With
With Application
.Range("A61:V61").ClearContents
.ScreenUpdating = True
End With
End Sub
What I want to do I think:
With wsInt
Dim f As Range
Set f = .Cell("Q23")
If IsEmpty(f) Then
MsgBox "The data can't entered, you have not entered any data into the Sales Order field."
Else
c = Array(.Range("B11"), .Range("B14"), .Range("B17"), .Range("B20"), .Range("Q23"), .Range("B23") _
, .Range("Q11"), .Range("Q14"), .Range("Q17"), .Range("Q20"), .Range("R26"), .Range("V23") _
, .Range("V25"), .Range("V27"), .Range("B32"), .Range("B40"), .Range("B46"), .Range("B52") _
, .Range("D58"), .Range("L58"), .Range("V58"))
End If
End With
Maybe as simple as:
With wsInt
If Len(.Range("Q23")) = 0 Then
MsgBox "The data can't be entered, you have not entered any data into the Sales Order field."
Exit Sub
End If
End With 'added this line for clarity