I want to make a macro that clears the content of the cells in the blue border (~40.000 Rows) when the cells in the red border (column AX) contain the text "NoBO" (=No Backorder) without losing the formulas in the columns AP:AX.
Sub clear_ranges()
Dim ws As Worksheet
Dim x As Integer
Dim clearRng As Range
Application.ScreenUpdating = False
Set ws = ThisWorkbook.Sheets("Input")
For x = 6 To ws.Range("B" & Rows.Count).End(xlUp).Row
If (ws.Range("AX6" & x).Value = "NoBO") Then
If clearRng Is Nothing Then
Set clearRng = ws.Range("B6" & x & ":" & "AN6" & x)
Else
Set clearRng = Application.Union(clearRng, ws.Range("B6" & x & ":" & "AN6" & x))
End If
End If
Next x
clearRng.Clear
End Sub
And for some reason:
For x = 6 To ws.Range("B" & Rows.Count).End(xlUp).Row
gives me a error "Overflow". After searching I know what this error means but I can't find a solution for this.
tl;dr - I want to delete the range B6:B##### (till last row) to AN6:AN####*(till last row) if cell AX##### containts NoBO
It is too easy to get an overflow using Integer. Replace:
Dim x As Integer
with:
Dim x As Long
Try:
Sub clear_ranges()
Dim ws As Worksheet
Dim x As Integer
Dim clearRng As Range
Application.ScreenUpdating = False
Set ws = ThisWorkbook.Sheets("Input")
For x = 6 To ws.Range("B" & Rows.Count).End(xlUp).Row
If ws.Range("AX" & x).Value = "NoBO" Then
ws.Range("B" & x & ":" & "AN" & x).Clear
End If
Next x
Application.ScreenUpdating = True
End Sub
I think the Union function can only store up to 30 ranges so it might not suit your needs.
Hi if you are Deleting Rows it's the Best to use a For Each Loop or start from the bottom of the column and work up.
'Loop through cells A6:Axxx and delete cells that contain an "x."
For Each c In Range("AX6:A" & ws.Range("B" & Rows.Count).End(xlUp).Row)
If c.Value2 = "NoBo" Then
Set clearRng = ws.Range("B" & c.Row & ":" & "AN" & c.Row)
End If
clearRng.Clear
Next
try this
Option Explicit
Sub clear_ranges()
Dim ws As Worksheet
Application.ScreenUpdating = False
Set ws = ThisWorkbook.Sheets("Input")
With ws
With .Range("B5:AX" & .Cells(.Rows.Count, "B").End(xlUp).Row) 'take all data
.AutoFilter Field:=49, Criteria1:="NoBO" 'filter to keep only rows with "NoBO" in column "AX" (which is the 49th column from column "B"
With .Offset(1).Resize(.Rows.Count - 1) 'offset from headers
If Application.WorksheetFunction.Subtotal(103, .Columns(1)) > 0 Then Intersect(.SpecialCells(xlCellTypeVisible), ws.Columns("B:AN")).ClearContents 'clear cells in columns "B:AN" of filtered rows
End With
.AutoFilter 'remove autofilter
End With
End With
Application.ScreenUpdating = True
End Sub
You can try
Assuming that there are no blank cells in AX Column
Sub clr_cell()
For i = 6 To ActiveSheet.Range("AX6", ActiveSheet.Range("AX6").End(xlDown)).Rows.Count
'counts the no. of rows in AX and loops through all
If ActiveSheet.Cells(i, 50).Value = "NoBo" Then
ActiveSheet.Range(Cells(i, 2), Cells(i, 40)).ClearContents
'clears range B to AN
End If
Next i
End Sub
I tested this on 40k rows and it worked fine. It takes a while to execute due to the no. of rows maybe.
Related
I have a Workbook with 6 Sheets. I am walking through them with For Each. And the task is:
1) Walk though every cell with specified Range
2) If cell is not empty AND contains ONLY number THEN add to the end of the cell " мм". Otherwise SKIP this cell.
But in fact, script does it good only for first sheet (Worksheet). It does no changes to other sheets. I don't know why this happens. I think, that there is some error or mistake in the code, but I double-checked it and everything seems to be correct. Help me please :)
Sub SaveWorksheetsAsCsv()
Dim xWs As Worksheet
Dim xDir As String
Dim folder As FileDialog
Dim r As Range
Dim rr As Range
Dim rrrrrr As Range
Dim cell As Range
k = Cells(Rows.Count, "A").End(xlUp).Row
Set folder = Application.FileDialog(msoFileDialogFolderPicker)
If folder.Show <> -1 Then Exit Sub
xDir = folder.SelectedItems(1)
For Each xWs In Application.ActiveWorkbook.Worksheets
If xWs.Name Like "Worksheet" Then
Set r = Range("FA2:FA" & k)
For Each cell0 In r
If IsEmpty(cell0.Value) = False And IsNumeric(cell0.Value) = True Then
cell0.Value = cell0.Value & " мм"
End If
Next
'xWs.Columns(41).EntireColumn.Delete
End If
If xWs.Name Like "Worksheet 1" Then
Set rr = Range("AG2:AG" & k)
For Each cell1 In rr
If IsEmpty(cell1.Value) = False And IsNumeric(cell1.Value) Then
cell1.Value = cell1.Value & " мм"
End If
Next
'xWs.Columns(126).EntireColumn.Delete
End If
If xWs.Name Like "Worksheet 5" Then
Set rrrrrr = Range("FR2:FR" & k)
For Each cell5 In rrrrrr
If IsEmpty(cell5.Value) = False And IsNumeric(cell5.Value) Then
cell5.Value = cell5.Value & " мм"
End If
Next
End If
xWs.SaveAs xDir & "\" & xWs.Name, xlCSV, local:=True
Next
End Sub
These sets of statements need to be adjusted to correct sheet references. Current code will always look at active sheet and the range reference is not qualified.
Set r = Range("FA2:FA" & k)
Set r = xWs.Range("FA2:FA" & k)
You can shorten-up and utilize your code a lot.
First, your k = Cells(Rows.Count, "A").End(xlUp).Row trying to get the last row, needs to be inside the For Each xWs In Application.ActiveWorkbook.Worksheets , since the last row will be different for each worksheet.
Second, instead of multiple Ifs, you can use Select Case.
Third, there is no need to have 3 different objects for Range, like r, rr, and rrr. The same goes for cell0, cell1 and cell5, you can use just one r and cell.
The only thing different inside your If (my Select Case) is the range you set r. The rest, looping through r.Cells is the same for all 3 criterias, so you can take this part outside the loop, and have it only once.
Modifed Code
Option Explicit
Sub SaveWorksheetsAsCsv()
Dim xWs As Worksheet
Dim xDir As String
Dim folder As FileDialog
Dim r As Range
Dim cell As Range
Dim k As Long
Set folder = Application.FileDialog(msoFileDialogFolderPicker)
If folder.Show <> -1 Then Exit Sub
xDir = folder.SelectedItems(1)
For Each xWs In ThisWorkbook.Worksheets ' it's safer to use ThisWorkbook is you reffer to the worksheets inside the workbook which thid code resides
With xWs
' getting the last row needs to be inside the loop
k = .Cells(.rows.Count, "A").End(xlUp).Row
Set r = Nothing ' reset Range Object
Select Case .Name
Case "Worksheet"
Set r = .Range("FA2:FA" & k)
'xWs.Columns(41).EntireColumn.Delete
Case "Worksheet 1"
Set r = .Range("AG2:AG" & k)
'xWs.Columns(126).EntireColumn.Delete
Case "Worksheet 5"
Set r = .Range("FR2:FR" & k)
End Select
' check if r is not nothing (it passed one of the 3 Cases in the above select case)
If Not r Is Nothing Then
For Each cell In r
If IsEmpty(cell.Value) = False And IsNumeric(cell.Value) Then
cell.Value = cell.Value & " мм"
End If
Next cell
End If
.SaveAs xDir & "\" & .Name, xlCSV, Local:=True
End With
Next xWs
End Sub
I'm sorting through data and need it to be formatted the same way. The input might have cells with
6+18
12
3
5+14
20
And I want to make them all integers. I've written this so far:
If InStr(data.Cells(x, 8), "+") > 0 Then
'Still trying to figure out this part
Else
calc.Cells((lrcalc + 1), (col + s)).Value = data.Cells(x, 8)
End If
How would I add the value on the left of the "+" sign to the value on the right?
Well there is no need to check for +. Simply add an = sign in each cell and let excel calculate it ;)
Sub Sample()
Dim lRow As Long, i As Long
Dim ws As Worksheet
'~~> Change this to the relevant sheet
Set ws = ActiveSheet
With ws
'~~> Find last row
lRow = .Range("A" & .Rows.Count).End(xlUp).Row
For i = 1 To lRow
With .Range("A" & i)
.Formula = "=" & .Value
.Value = .Value
End With
Next i
End With
End Sub
Screenshot
I have two workbooks:
Planner
Column K Column AG
123 £100
246 £20
555 £80
Master
Column D Column R
123 £100
246 £20
555 £80
I am trying to copy the values from Planner, Column AG into Column R (Master) where my item numbers in Column D (Master) match with column K (Planner).
My code below produces no error and it is not producing any results - despite their being several matches.
Please can someone show me where i am going wrong?
For the avoidance of doubt, my workbook is definitely opening ok so is finding the file.
Code:
Sub PlannerOpen()
'Set Variables
Dim wb2 As Workbook
Dim i As Long
Dim j As Long
Dim lastRow As Long
Dim app As New Excel.Application
'Find Planner
If Len(FindDepotMemo) Then
'If Found Then Set Planner Reference.
app.Visible = False 'Visible is False by default, so this isn't necessary
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Application.EnableEvents = False
Set wb2 = Workbooks.Open(FindDepotMemo, ReadOnly:=True, UpdateLinks:=False)
'If We have our planner lets continue...
'With my workbook
With wb2.Worksheets(1)
lastRow = .Cells(.Rows.Count, "K").End(xlUp).Row
'Lets begin our data merge
j = 2
For i = 2 To lastRow
'If data meets criteria
'Check Planner For Turnover
If ThisWorkbook.Worksheets("Data").Range("D" & j).Value = .Range("K" & i).Value Then ' check if Item number matches
ThisWorkbook.Worksheets("Data").Range("R" & j).Value = .Range("AG" & i).Value
j = j + 1
End If
'Continue until all results found
Next i
End With
'All Done, Let's tidy up
'Close Workbooks
'wb2.Close SaveChanges:=False
'app.Quit
'Set app = Nothing
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Application.EnableEvents = True
End If
End Sub
Function FindDepotMemo() As String
Dim Path As String
Dim FindFirstFile As String
Path = "G:\BUYING\Food Specials\2. Planning\1. Planning\1. Planner\" & "8." & " " & Year(Date) & "\"
FindFirstFile = Dir$(Path & "*.xlsx")
While (FindFirstFile <> "")
If InStr(FindFirstFile, "Planner") > 0 Then
FindDepotMemo = Path & FindFirstFile
Exit Function
End If
FindFirstFile = Dir
Wend
End Function
Instead of having 2 For loops, just use the Application.Match to find matches between values in your 2 workbooks.
Use this code section below to replace with yours:
With wb2.Worksheets(1)
Dim MatchRow As Variant '<-- define variable to get the row number if Match is successful
lastRow = .Cells(.Rows.Count, "K").End(xlUp).Row
'Lets begin our data merge
For i = 2 To lastRow
' If data meets criteria
' Check Planner For Turnover
' Use Application.Match to find matching results between workbooks
If Not IsError(Application.Match(ThisWorkbook.Worksheets("Data").Range("D" & i).Value, .Range("K2:K" & lastorw), 0)) Then ' check if Match is successful
MatchRow = Application.Match(ThisWorkbook.Worksheets("Data").Range("D" & i).Value, .Range("K2:K" & lastorw), 0) ' <-- get the row number where the match was found
ThisWorkbook.Worksheets("Data").Range("R" & j).Value = .Range("AG" & MatchRow).Value
End If
'Continue until all results found
Next i
End With
you could refactor your code as follows:
Option Explicit
Sub PlannerOpen()
Dim dataRng As Range, cell As Range
Dim depotMemo As String
Dim iRow As Variant
If FindDepotMemo(depotMemo) Then '<--| if successfully found the wanted file
With ThisWorkbook.Worksheets("Data1") '<--| reference your "Master" workbook relevant worksheet
Set dataRng = .Range("D2", .Cells(.Rows.Count, "D").End(xlUp)) '<--| set its item numbers range
End With
With Workbooks.Open(depotMemo, ReadOnly:=True, UpdateLinks:=False).Worksheets(1) '<--| open depotMemo workbook and reference its first worksheet
For Each cell In .Range("K2", .Cells(.Rows.Count, "K").End(xlUp)) '<--| loop through referenced worksheet column "K" cells from row 2 down to last not empty one
iRow = Application.Match(cell.Value, dataRng, 0) '<--| try finding current depotMemo item number in Master item numbers range
If Not IsError(iRow) Then dataRng(iRow, 1).Offset(, 14).Value = cell.Offset(, 22) '<--| if found then grab depotMemo current item amount and place it in corresponding "master" data sheet column R
Next
.Parent.Close False
End With
End If
End Sub
Function FindDepotMemo(depotMemo As String) As Boolean
Dim Path As String
Dim FindFirstFile As String
Path = "G:\BUYING\Food Specials\2. Planning\1. Planning\1. Planner\" & "8." & " " & Year(Date) & "\"
FindFirstFile = Dir$(Path & "*.xlsx")
While (FindFirstFile <> "")
If InStr(FindFirstFile, "Planner") > 0 Then
FindDepotMemo = True
depotMemo = Path & FindFirstFile
Exit Function
End If
FindFirstFile = Dir
Wend
End Function
My original question was posted here.
Basically I needed some help transferring data from one sheet to another based on values in the first sheet. I am using a modified bit of code provided by user keong kenshih.
I added an additional check against another row to the IF statement, and I have this for my code:
Option Explicit
Dim MyWorkbook As Workbook
Dim MyWorksheet As Worksheet
Dim MyOutputWorksheet As Worksheet
So I need to output only certain columns. Also I need them to import to certain rows and columns on the second sheet, the CONTRACT sheet. Column A on the MAIN sheet goes to column A starting at row 17 on the CONTRACT sheet. B to B , E to D, F to E, all starting at row 17 on the CONTRACT sheet.
Rows 17-42 on the CONTRACT sheet will contain data.
Sub PullData()
Set MyWorkbook = Workbooks(ActiveWorkbook.Name)
Set MyWorksheet = MyWorkbook.Sheets("MAIN")
Set MyOutputWorksheet = MyWorkbook.Sheets("CONTRACT")
Dim myValue As Long
Dim RowPointer As Long
For RowPointer = 6 To MyWorksheet.Cells(Rows.Count, "B").End(xlUp).Row
If MyWorksheet.Range("A" & RowPointer).V alue > 0 And
MyWorksheet.Range("A" & RowPointer).Value <> ""
MyWorksheet.Range("F" & RowPointer).Value > 0 And
MyWorksheet.Range("F" & RowPointer).Value <> ""Then
If MyOutputWorksheet.Cells(Rows.Count, "B").End(xlUp).Row > 15
Then
Exit Sub
End If
MyWorksheet.Range(("A" & RowPointer) & ":C" & RowPointer).Copy
Destination:=MyOutputWorksheet.Range("A" &
MyOutputWorksheet.Cells(Rows.Count, "B").End(xlUp).Row + 1)
End If
Next RowPointer
End Sub
Give this a try :
Sub PullData()
Dim wRow As Long, _
RowPointer As Long, _
MyWorkbook As Workbook, _
Ws As Worksheet, _
OutWs As Worksheet
Set MyWorkbook = Workbooks(ActiveWorkbook.Name)
Set Ws = MyWorkbook.Sheets("MAIN")
Set OutWs = MyWorkbook.Sheets("CONTRACT")
With Ws
For RowPointer = 6 To .Cells(.Rows.Count, "B").End(xlUp).Row
If .Range("A" & RowPointer).Value > 0 And _
.Range("A" & RowPointer).Value <> "" And _
.Range("F" & RowPointer).Value > 0 And _
.Range("F" & RowPointer).Value <> "" Then
'This line would get you out of the loop after the first copy because _
'You first paste on line 17 and then the below left part will be equal to 18
'If OutWs.Cells(OutWs.Rows.Count, "B").End(xlUp).Row > 15 Then Exit Sub
wRow = OutWs.Rows(OutWs.Rows.Count).End(xlUp).Row + 1
'Always start copy after (or at) line 17
If wRow <= 17 Then wRow = 17
'More efficient way to copy data between ranges
OutWs.Range("A" & wRow).Value = Ws.Range("A" & RowPointer)
OutWs.Range("B" & wRow).Value = Ws.Range("B" & RowPointer)
OutWs.Range("D" & wRow).Value = Ws.Range("E" & RowPointer)
OutWs.Range("E" & wRow).Value = Ws.Range("F" & RowPointer)
End If
Next RowPointer
End With
Set MyWorkbook = Nothing
Set Ws = Nothing
Set OutWs = Nothing
End Sub
I have a problem with my code about delete blank rows. It just has to delete some rows not all blank rows and rows value "0". I don't wanna use .SpecialCells(xlCellTypeBlanks) as some threat on SO forum.
Dim R As Integer
R = Range("CuoiNKC").Row - 1
Dim DelCell As Range
Dim DelRange As Range
Set DelRange = Range("J9:J" & R)
For Each DelCell In DelRange
If DelCell.Value = "0" Or DelCell.Formula = Space(0) Then
DelCell.EntireRow.Delete
End If
Next DelCel
Why don't you use Range AutoFilter Method instead of looping.
Assuming you have the correct value of DelRange in your code, try this:
DelRange.AutoFilter 1, AutoFilter 1, "=0", xlOr, "=" 'filtering 0 and space
DelRange.SpecialCells(xlCellTypeVisible).EntireRow.Delete xlUp 'delete visible cells
ActiveSheet.AutoFilterMode = False 'remove auto filter mode
Btw, if you want to stick with your logic, you need to iterate the rows backward.
You can only do that using the conventional For Next Loop. Again assuming value of R is correct.
For i = R To 9 Step -1
If Range("J" & i).Value = "0" Or Range("J" & i).Value = " " Then
Range("J" & i).EntireRow.Delete xlUp
End If
Next