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
Related
I am new to macros. I have this below code in which I am trying to copy some filtered data from one sheet and paste in another worksheet in the end but getting error in the pasting step. I dont know how to correct that. Can someone please help me on this?
Sub MyTest()
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim i As Long
Dim j As Long
Dim LastRow As Long
Dim r As Long
Dim str As String
Dim lRow As Long
Application.ScreenUpdating = False
Set ws1 = Sheets("Sheet2")
Set ws2 = Sheets("Sheet1")
lr1 = Cells(Rows.Count, 3).End(xlUp).Row
lr2 = Cells(Rows.Count, 2).End(xlUp).Row
For r = lr1 To 5 Step -1
ws2.Activate
str = ws2.Cells(r, "C")
i = Application.WorksheetFunction.CountIf(ws1.Columns(1), str)
If i > 1 Then ws2.Rows(r + 1 & ":" & r + i - 1).Insert
ws2.Range(Cells(r, "C"), Cells(r + i - 1, "C")) = str
ws2.Activate
ws2.Range("$A$4:$W$4").AutoFilter Field:=3, Operator:=xlFilterValues, Criteria1:=str
ws1.Activate
ws1.Range("$A$1:$D$1").AutoFilter Field:=1, Operator:=xlFilterValues, Criteria1:=str
ActiveSheet.AutoFilter.Range.Offset(1).SpecialCells(xlCellTypeVisible).Cells(1, 2).Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.SpecialCells(xlCellTypeVisible).Copy
ws2.Activate
ws2.Range("$A$4:$W$4").AutoFilter Field:=3, Operator:=xlFilterValues, Criteria1:=str
ActiveSheet.AutoFilter.Range.Offset(1).SpecialCells(xlCellTypeVisible).Cells(1, 8).Select
Selection.PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
Next r
End Sub
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.
I have tried several methods to eliminate my VBA error but it does not help.
During the first run, there will be error code 9. Upon running again, the code works fine. I have another code with no error but does not execute the VBA code correctly the first run. Upon running the code again, it execute the VBA code correctly.
I have tried using F8 to debug the problem, i have tried looping.
Sub TXNFont()
Dim Firstrow As Long
Dim Lastrow As Long
Dim Lrow As Long
Dim CalcMode As Long
Dim lastColumn As Integer
Dim rng As Range
Set rng = ActiveSheet.Cells
Sheets("TXN Speed").Select
lastColumn = rng.Find(What:="*", After:=rng.Cells(1), Lookat:=xlPart, LookIn:=xlFormulas, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious, MatchCase:=False).Column
With Application
CalcMode = .Calculation
.Calculation = xlCalculationManual
End With
Sheets("TXN Speed").Select
Cells.Select
With ActiveSheet
.Select
Firstrow = .UsedRange.Cells(1).Row
Lastrow = .UsedRange.Rows(.UsedRange.Rows.Count).Row
For Lrow = Lastrow To Firstrow Step -1
With .Cells(Lrow, lastColumn)
If Not IsError(.Value) Then
If .Value > 3500 Then .EntireRow.Font.Color = RGB(255, 0, 0)
End If
End With
Next Lrow
End With
With Application
.Calculation = CalcMode
End With
Sheets("TXN Speed").Select
With ActiveSheet
.Select
Range("A1:A5").EntireRow.Font.Color = RGB(0, 0, 0)
End With
End Sub
Sub NetFont()
Dim Firstrow As Long
Dim Lastrow As Long
Dim Lrow As Long
Dim CalcMode As Long
Dim lastColumn As Integer
Dim rng As Range
Set rng = ActiveSheet.Cells
With Sheets("Network").Select
Cells.Select
With Selection.Font
.ThemeColor = xlThemeColorLight1
.TintAndShade = 0
End With
lastColumn = rng.Find(What:="*", After:=rng.Cells(1), Lookat:=xlPart, LookIn:=xlFormulas, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious, MatchCase:=False).Column
Cells.Select
Cells.Select
With ActiveSheet
.Select
Firstrow = .UsedRange.Cells(1).Row
Lastrow = .UsedRange.Rows(.UsedRange.Rows.Count).Row
For Lrow = Lastrow To Firstrow Step -1
With .Cells(Lrow, lastColumn)
If Not IsError(.Value) Then
If .Value < 10 Then .EntireRow.Font.Color = RGB(255, 0, 0)
End If
End With
Next Lrow
End With
With Application
.Calculation = CalcMode
End With
Sheets("Network").Select
With ActiveSheet
.Select
Range("A1:A5").EntireRow.Font.Color = RGB(0, 0, 0)
End With
End With
End Sub
Sub TXNFont() will have error during first run, but will execute the code with no issue if I hit run again.
Sub NetFont() will execute the coding with error during first run, but will execute the code correctly if I hit run again.
These codes were link to another VBA code which was running fine with no issue. I hope that the codes I made run smoothly with no error during their first run. Thanks in advance people!
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 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