I am trying to select the column that contains SUM formula. and I want to copy the formula and past only the value in the same column. but this code does not change the formula into the value. any idea how i could solve this?
Sub Registrereren()
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
Application.ScreenUpdating = False
On Error Resume Next
Dim oWkSht As Worksheet
Dim LastColumn As Long
Dim c As Date
Dim myCell As Range
Dim LastRow As Long
Sheets("Registration").Activate
Set oWkSht = ThisWorkbook.Sheets("Registration")
LastColumn = oWkSht.Range("A" & Columns.Count).End(xlToRight).Column
LastRow = oWkSht.Range("C" & Rows.Count).End(xlUp).Row
c = Date
Set myCell = oWkSht.Range("1:1").Find(What:=c, LookIn:=xlValues, lookat:=xlWhole, MatchCase:=False, SearchOrder:=xlByColumns)
If Not myCell Is Nothing Then
myCell.Offset(1, 0).Formula = "=New_Order!N2+New_Order!O2+New_Order!P2"
Range(myCell.Offset(1), Cells(LastRow, myCell.Column)).Select
Selection.FillDown
Range(myCell.Offset(1), LastRow).Select
Selection.Copy
Range(myCell.Offset(1), LastRow).PasteSpecial xlPasteValues
End If
Sheets("Main").Activate
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
Try this. LastRow is not a valid range as it is only a row number.
Sub Registrereren()
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
Application.ScreenUpdating = False
Dim oWkSht As Worksheet
Dim LastColumn As Long
Dim c As Date
Dim myCell As Range
Dim LastRow As Long
Set oWkSht = ThisWorkbook.Sheets("Registration")
LastColumn = oWkSht.Range("A" & Columns.Count).End(xlToRight).Column
LastRow = oWkSht.Range("C" & Rows.Count).End(xlUp).Row
c = Date
Set myCell = oWkSht.Range("1:1").Find(What:=c, LookIn:=xlValues, lookat:=xlWhole, MatchCase:=False, SearchOrder:=xlByColumns)
If Not myCell Is Nothing Then
With oWkSht.Range(myCell.Offset(1), oWkSht.Cells(LastRow, myCell.Column))
.Formula = "=New_Order!N2+New_Order!O2+New_Order!P2"
.Value = .Value
End With
End If
Sheets("Main").Activate
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
Related
I use this piece of code to delete any blank rows in my excel file and then adjust the structure so there won't be a blank hole in the file.
But I found out that this part of the code put my script in an infinite loop.
Does somebody know what I can change to stop this piece of code let my script go in an infinite loop or is there maybe a better way to delete blank rows?
Dim LastRowIndex As Integer
Dim RowIndex As Integer
Dim UsedRng As Range
Set UsedRng = ActiveSheet.UsedRange
LastRowIndex = UsedRng.Row - 1 + UsedRng.Rows.Count
Application.ScreenUpdating = False
For RowIndex = LastRowIndex To 1 Step -1
If Application.CountA(Rows(RowIndex)) = 0 Then
Rows(RowIndex).Delete
End If
Next RowIndex
Application.ScreenUpdating = False
Dim n As Long
The hole code looks like:
Dim cell As Range
lastRow = ActiveSheet.Cells(ActiveSheet.Rows.Count, "C").End(xlUp).Row
For Each cell In ActiveSheet.Range("C2:C" & lastRow)
S = vbNullString
If cell.Value <> vbNullString Then
v = Split(cell.Value, " ")
For Each W In v
S = S & Left$(W, 1) & "."
Next W
cell.Offset(ColumnOffset:=-1).Value = S
End If
Next cell
Application.Range("B1").Value = "tesing"
Worksheets("sheet1").Range("B1").Font.Bold = True
Columns("D").Replace What:="vander", _
Replacement:="van der", _
LookAt:=xlPart, _
SearchOrder:=xlByRows, _
MatchCase:=False, _
SearchFormat:=False, _
ReplaceFormat:=False
Columns("D").Replace What:="vanden", _
Replacement:="van den", _
LookAt:=xlPart, _
SearchOrder:=xlByRows, _
MatchCase:=False, _
SearchFormat:=False, _
ReplaceFormat:=False
Columns("B").Replace What:="..", _
Replacement:=".", _
LookAt:=xlPart, _
SearchOrder:=xlByRows, _
MatchCase:=False, _
SearchFormat:=False, _
ReplaceFormat:=False
'Beta code'
Dim r As Range
For Each r In ActiveSheet.UsedRange
If Not IsError(r.Value) Then
v = r.Value
If v <> vbNullString Then
If Not r.HasFormula Then
r.Value = Trim(v)
End If
End If
End If
Next r
'NIEUW NIEUW NIEUW NIEUW NIEUW NIEUW NIEUW NIEUW '
ActiveWorkbook.Worksheets("sheet1").Range("A2:Z5000").Font.Bold = False
ThisWorkbook.ActiveSheet.Cells.Range("A2:Z5000").ClearFormats
Range("A1:Z5000").Font.Color = vbBlack
Range("G2:G5000,A2:A5000,H2:H5000").Clear
Worksheets("sheet1").Columns("A:M").AutoFit
Application.EnableEvents = True
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Const RolesList As String = "Testing"
Const FirstCellAddress As String = "L2"
Const Delimiter As String = "||"
Dim rng As Range
With Range(FirstCellAddress)
Set rng = Intersect(.Resize(.Worksheet.Rows.Count - .Row + 1), Target)
End With
If rng Is Nothing Then
Exit Sub
End If
Dim Roles() As String: Roles = Split(RolesList, ",")
Dim dRng As Range
Dim aRng As Range
Dim cel As Range
Dim Curr() As String
Dim cMatch As Variant
Dim n As Long
Dim isFound As Boolean
For Each aRng In rng.Areas
For Each cel In aRng.Cells
If Not IsError(cel) Then
Curr = Split(cel.Value, Delimiter)
For n = 0 To UBound(Curr)
cMatch = Application.Match(Curr(n), Roles, 0)
If IsError(cMatch) Then
isFound = True
Exit For
Else
' Remove this block if you don't need case-sensitivity.
If StrComp(Curr(n), Roles(cMatch - 1), _
vbBinaryCompare) <> 0 Then
isFound = True
Exit For
End If
End If
Next n
If isFound Then
isFound = False
If dRng Is Nothing Then
Set dRng = cel
Else
Set dRng = Union(dRng, cel)
End If
End If
End If
Next cel
Next aRng
Application.ScreenUpdating = False
rng.Interior.Color = xlNone
If Not dRng Is Nothing Then
dRng.Interior.Color = vbRed
End If
Application.ScreenUpdating = True
End Sub
I replaced the code above with, it works now:
Application.EnableEvents = True
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Dim i As Long
Dim DelRange As Range
On Error GoTo Whoa
Application.ScreenUpdating = False
For i = 1 To 50
If Application.WorksheetFunction.CountA(Range("A" & i & ":" & "Z" & i)) = 0 Then
If DelRange Is Nothing Then
Set DelRange = Range("A" & i & ":" & "Z" & i)
Else
Set DelRange = Union(DelRange, Range("A" & i & ":" & "Z" & i))
End If
End If
Next i
If Not DelRange Is Nothing Then DelRange.Delete shift:=xlUp
LetsContinue:
Application.ScreenUpdating = True
Exit Sub
Whoa:
MsgBox Err.Description
Resume LetsContinue
I have code that runs in several other workbooks but seems to be ignored in a specific one.
The only difference I can see between the ones that work and the one that doesn't, is a line that has SaveAs Filename: vs SaveAs FileName:. Somehow I cannot imagine that would cause the whole script to be ignored but??
The other thing is when I attempt to change the code from Filename to FileName, excel changes it back as soon as I go to the next line.
Corrupt file?
Apologies for the sloppy code... :(
```Sub Create_Individual_Files()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.DisplayAlerts = False
Dim i As Integer
Dim x As String
Dim Lastrow As Long
Dim NewBook As Workbook
Dim Sourcewb As Workbook: Set Sourcewb = ThisWorkbook
Dim FileExtStr As String
Dim FileFormatNum As Long
Dim FName As String
Dim Fpath As String
Dim FName2 As String
Fpath = Sheets("Variables").Range("B1").Text
FName = Sheets("Variables").Range("B9").Text
FName2 = Sheets("Variables").Range("B2").Text
'Find the last row of data in each tab.
Lastrow = Sourcewb.Sheets(1).Cells(Sourcewb.Sheets(1).Rows.Count, "A").End(xlUp).Row
'This section creates each new file, retaining all formulas, from the existing tabs in the master workbook. Then saves the file with the individuals name.
For i = 2 To Lastrow
x = Sourcewb.Sheets(1).Range("A" & i).Value
Sourcewb.Sheets(Array("Summary", "Pivot", "Data", "Modifier %", "Modifier Dollar", "Variables")).Copy
Set NewBook = ActiveWorkbook
FileExtStr = ".xlsx": FileFormatNum = 51
With NewBook
.SaveAs Filename:=Fpath & FName2 & "-" & x & FName & ".xlsx"
'.Close False
End With
''''''''''''''''''''''''''''''''''''''''''''
'The section below deletes data from each tab that is not specific to the individual.
Sheets("Variables").Select
' Range("C5").Select
' Selection.Copy
Range("B10").Select
ActiveCell.FormulaR1C1 = x
' Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
' :=False, Transpose:=False
Sheets("Summary").Select
Call Loop_Delete_Summary
Sheets("Data").Select
ActiveSheet.ListObjects(1).Unlist
Call Loop_Delete_Summary
Sheets("Modifier %").Select
ActiveWorkbook.ActiveSheet.ListObjects(1).Unlist
Call Delete_Modifier_Percent
Sheets("Modifier Dollar").Select
ActiveSheet.ListObjects(1).Unlist
Call Loop_Delete_Summary
'Sheets("Controls").Select
Sheets("Variables").Select
ActiveWindow.SelectedSheets.Delete
Call ResetCursor
''''''''''''''''''''''''''''''''''''''''''''
Next i
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.DisplayAlerts = True
End Sub```
```Sub Loop_Delete_Summary()
Dim Firstrow As Long
Dim Lastrow As Long
Dim Lrow As Long
Dim CalcMode As Long
Dim ViewMode As Long
Dim rng As Range
With ActiveSheet
.Select
ViewMode = ActiveWindow.View
ActiveWindow.View = xlNormalView
'Set the first and last row to loop through
Firstrow = .UsedRange.Offset(1).Row
Lastrow = .UsedRange.Rows(.UsedRange.Rows.Count).Row
'Loop from Lastrow to Firstrow (bottom to top)
For Lrow = Lastrow To Firstrow Step -1
'Check the values in the A column
With .Cells(Lrow, "A")
If Not IsError(.Value) Then
If .Value <> Worksheets("Variables").Range("B10") Then
If rng Is Nothing Then
Set rng = .Cells
Else
Set rng = Application.Union(rng, .Cells)
End If
End If
End If
End With
Next Lrow
End With
'Delete all rows at once
If Not rng Is Nothing Then rng.EntireRow.Delete
ActiveWindow.View = ViewMode
With Application
.ScreenUpdating = True
.Calculation = CalcMode
End With
End Sub```
```Sub Loop_Delete_Modifier_Percent()
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 = 2
Lastrow = .Cells(.Rows.Count, "B").End(xlUp).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")
If Not IsError(.Value) Then
Select Case .Value
Case Is <> Worksheets("Variables").Range("B10").Value: .EntireRow.Delete
End Select
End If
End With
Next Lrow
End With
ActiveWindow.View = ViewMode
With Application
.ScreenUpdating = True
.Calculation = CalcMode
End With
End Sub```
*****The code when using F8 to step through seems to skip over this section...*****
``` x = Sourcewb.Sheets(1).Range("A" & i).Value
Sourcewb.Sheets(Array("Summary", "Pivot", "Data", "Modifier %", "Modifier Dollar", "Variables")).Copy
Set NewBook = ActiveWorkbook
FileExtStr = ".xlsx": FileFormatNum = 51
With NewBook
.SaveAs Filename:=Fpath & FName2 & "-" & x & FName & ".xlsx"
'.Close False
End With
Sheets("Variables").Select
' Range("C5").Select
' Selection.Copy
Range("B10").Select
ActiveCell.FormulaR1C1 = x
' Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
' :=False, Transpose:=False
Sheets("Summary").Select
Call Loop_Delete_Summary
Sheets("Data").Select
ActiveSheet.ListObjects(1).Unlist
Call Loop_Delete_Summary
Sheets("Modifier %").Select
ActiveWorkbook.ActiveSheet.ListObjects(1).Unlist
Call Delete_Modifier_Percent
Sheets("Modifier Dollar").Select
ActiveSheet.ListObjects(1).Unlist
Call Loop_Delete_Summary
'Sheets("Controls").Select
Sheets("Variables").Select
ActiveWindow.SelectedSheets.Delete
Call ResetCursor
Next i```
It appears that the order of the tabs was the issue. I noticed that Lastrow = Sourcewb.Sheets(1).Cells(Sourcewb.Sheets(1).Rows.Count, "A").End(xlUp).Row
Lastrow = 0.
I moved the front 2 tabs which had no data to the end of the tabs and it works.
Otherwise, for whatever reason, it would find zero as the last row and simply skip to the end.
Good day to everyone,
I have been trying to find an answer here that would fit my problem but I have been unsuccessful. I am using FIND to search column F for cell with #N/A value and copy adjacent cells to another "Sheet2" at the end of the column A. I have made the following code that works but my problem is I want to make it to loop to find the next cell with #N/A value till find all.
Sub Find()
Dim SerchRange As Range
Dim FindCell As Range
Set SerchRange = Range("F:F")
Set FindCell = SerchRange.FIND(What:="#N/A", _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False)
If FindCell Is Nothing Then
MsgBox "Nothing was found all clear"
Else
FindCell.Select
ActiveCell.Offset(0, -3).Resize(, 3).Select
Selection.Copy
Sheets("Sheet2").Select
Cells(Rows.Count, "A").End(xlUp).Offset(1, 0).Select
ActiveSheet.Paste
End If
End Sub
Try this and let me know if it works:
Option Explicit
Sub Find()
Application.ScreenUpdating = False
Dim SearchRange As Range
Dim FindCell As Range
Dim Check As Boolean
Dim LastRow As Long
Dim ws As Worksheet
Dim ws2 As Worksheet
Dim FindCounter As Long
Set ws = ThisWorkbook.Worksheets("Sheet1") ' <--- Insert the name of your worksheet here
Set ws2 = ThisWorkbook.Worksheets("Sheet2")
LastRow = ws.Cells(Rows.Count, "F").End(xlUp).Row ' <--- Finds the last used row
Set SearchRange = Range("F1:F" & LastRow)
FindCounter = 0
For Each FindCell In SearchRange
If FindCell.Value = "#N/A" Then
FindCounter = FindCounter + 1
FindCell.Offset(0, -3).Resize(, 3).Copy
ws2.Range("A" & ws2.Cells(Rows.Count, "A").End(xlUp).Row + 1).PasteSpecial xlPasteValues
End If
Next
MsgBox "Succes!" & vbNewLine & vbNewLine & "This many cells were found: " & FindCounter
Application.ScreenUpdating = True
End Sub
I am trying to run a match of values from sheet 10 which loops from 2 to 11000
looking for a match in in column A of sheet 10 with column A of sheet3. Then if matched copy value from column B sheet 3 to column F of sheet10 , my code below works , but it takes 25 mins to run. Is there a quicker way to run this please
Sub update_OpGroup()
Dim lastrow10, lastrow3
lastrow10 = Sheet10.Range("A" & Rows.Count).End(xlUp).Row
lastrow3 = Sheet3.Range("A" & Rows.Count).End(xlUp).Row
Dim x, y, b
b = 2
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
For x = 1 To lastrow10
For y = 2 To lastrow3
If Sheet10.Range("A" & x).Value = Sheet3.Range("A" & y).Value Then Sheet10.Range("F" & x).Value = Sheet3.Range("B" & y).Value: GoTo foundit
Next y
foundit:
Next x
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
End Sub
you could use Find() method of Range object:
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
Dim found As Range
For x = 1 To lastrow10
Set found = Sheet3.Range("A2:A" & lastrow3).Find(what:=Sheet10.Range("A" & x).Value, lookat:=xlValues, LookIn:=xlWhole)
If Not found Is Nothing Then Sheet10.Range("F" & x).Value = Sheet3.Range("B" & found.Row).Value
Next x
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
I believe an INDEX/MATCH formula may fulfill your needs much quicker than VBA copy/paste.
If the range in column A is always fixed, the below formula works:
=INDEX(Sheet3!$B:$B,MATCH(Sheet10!$A:$A,Sheet3!$A:$A,0),1)
If the range is varied, the below VBA should cover it:
Sub Fill_Formula()
Dim lRow As String
lRow = Worksheets("Sheet10").Range("A:A").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
Worksheets("Sheet10").Range("F2").FormulaR1C1 = "=INDEX(Sheet3!C2,MATCH(Sheet10!C1,Sheet3!C1,0),1)"
Worksheets("Sheet10").Range("F2").AutoFill Destination:=Worksheets("Sheet10").Range("F2:F" & lRow), Type:=xlFillDefault
End Sub
If a formula isn't acceptable in the cells you could add:
Worksheets("Sheet10").Range("F2:F" & lRow).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Hi I have the following code which works ok. My question is how can I set the destination for auto fill to Range(selection, LastRow) instead of
Range(selection, selection.End(xlDown). because this does the autofill for the entire column even does areas that there is no information in it it fills them with 0.
Sub usingfind()
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
Application.ScreenUpdating = False
Dim oWkSht As Worksheet
Dim PWkSht As Worksheet
Dim LastColumn As Long
Dim i As Long
Dim c As Date
Dim myCell As Range
Dim Home As Range
Dim Sgf As Range
Dim Vracht As Range
Dim LastRow As Long
Dim j As Long
Set oWkSht = ThisWorkbook.Sheets("Registration")
LastColumn = oWkSht.Range("A" & Columns.Count).End(xlToRight).Column
LastRow = oWkSht.Range("C" & Rows.Count).End(xlUp).Row
c = Date
Set myCell = oWkSht.Range("1:1").Find(What:=c, LookIn:=xlValues, lookat:=xlWhole, MatchCase:=False, SearchOrder:=xlByColumns)
If Not myCell Is Nothing Then
myCell.Offset(1, 0).Select
ActiveCell.FormulaR1C1 = "=SUM(New_Order!RC[-41]:RC[-39])"
myCell.Offset(1, 0).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.FillDown
End If
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub