I'm trying to run a simple nested If & Do Until loop for multiple sheets:
Sub DoUntil()
Dim ws As Worksheet
Dim i As Integer
For Each ws In ActiveWorkbook.Worksheets
For i = 1 To 25
If ws.Cells(i, 10) = "T" Then
ws.Cells(i, 10).Select
Do Until ActiveCell = "P"
ActiveCell.Offset(1, 1) = 1
ActiveCell.Offset(1, 0).Select
Loop
End If
Next i
Next ws
End Sub
PURPOSE: This function is meant to loop through a column, and place 1's in the next column to the right. The 1's must start just after "T" and end at "P". The T's and P's are unevenly spaced.
PROBLEM: Running this code for a single worksheet without the ws. object gives no problem. However, as soon as I want to loop through multiple worksheets, the .Select fails to fetch the specified range (Error 1004). This error is given at
ws.Cells(i, 10).Select
QUESTION: I know the perils of using the .Select property, but I'm unsure of how to tackle this problem differently as the ActiveCell is crucial for my Do Until function. Is there another way to run my Do Until function that will work with the If statement and loop through multiple sheets?
Try the below:
Sub DoUntil()
Dim ws As Worksheet
Dim i As Integer, j as Integer
For Each ws In ActiveWorkbook.Worksheets
For i = 1 To 25
If ws.Cells(i, 10) = "T" Then
j = i
Do Until ws.Cells(j,10) = "P"
ws.Cells(j, 10+1) = 1
j = j + 1
Loop
End If
Next i
Next ws
End Sub
use match, something like
cells(match("T",range("a1:a50000"),0),1) to
cells(match("P",range("a" & match("T",range("a1:a50000"),0) & ":a50000"),0),1)
and something like
range(cells(y,x),cells(y2,x2)).offset(0,1).value=1
Related
I am fairly new to VBA and Wondering if someone can help me out.
I have 2 different sheets in a workbook.
Sheet(Raw Data) has a range with Cost Center NameS (Cell BC3 down to empty)
I have to copy Sheet(CC Template) and name it the right 5 characters of Sheet(Raw Data).Range(BC3).Value and change Cell(2,2).value to Sheet(Raw Data).Range(BC3).Value...
Then I want it to go to the next cell in Sheet(Raw Data) ...BC4 and create the second sheet and change the name and Cell(2,2) accordingly until the list in Sheet(Raw Data) ends.
Here is my Code. It creates the first worksheet but then I get run-time Error '1004' at Sheets("Raw Data").Range("BC3").Select in the do until loop. I would like to get rid of X and CCName variable from the code also if possible.
Sub CreateCCTabsinNewPlantFile2()
Dim i As Integer
Dim x As Integer
Dim CCName As String
i = ActiveWorkbook.Worksheets.Count
x = 1
' Select cell BC3, *first line of data*.
Sheets("Raw Data").Range("BC3").Select
' Set Do loop to stop when an empty cell is reached.
Do Until IsEmpty(ActiveCell)
CCName = ActiveCell.Value
' Code to make worksheets
Worksheets("CC Template").Copy after:=Worksheets(i)
ActiveSheet.Name = Right(CCName, 5)
ActiveSheet.Cells(2, 2).Value = CCName
' Step down 1 row from present location.
Sheets("Raw Data").Range("BC3").Select
ActiveCell.Offset(x, 0).Select
x = x + 1
Loop
End Sub
Sub CreateCCTabsinNewPlantFile2()
Dim i As Integer
Dim X As Integer
X = 3 'Starting row in Sheet("Raw Data")
With ThisWorkbook.Sheets("Raw Data")
Do Until .Cells(X, 55).Value = "" 'cells(x,55)= BC3. First time x= 3 so Cells(3,55)=BC3
i = ThisWorkbook.Worksheets.Count 'we update count everytime, because we are adding new sheets
ThisWorkbook.Worksheets("CC Template").Copy after:=ThisWorkbook.Worksheets(i)
ThisWorkbook.ActiveSheet.Name = Right(.Cells(X, 55).Value, 5)
ThisWorkbook.ActiveSheet.Cells(2, 2).Value = .Cells(X, 55).Value
' We increade X. That makes check a lower rower in next loop.
X = X + 1
Loop
End With
End Sub
Hope this helps.
You get error1004 because you can use Range.Select only in Active Sheet. If you want to Select a Range in different Sheet, first you must Activate that sheet with Sheets("Whatever").Activate.
Also, I Updated your code so you can execute it from any sheet. Your code forces user to have Sheets ("Raw Data") as the ActiveSheet.
Try not use too much Select if you can avoid it. And also , try to get used to Thisworkbook instead of ActiveWorkbook. If you work always in same workbook, is not a problem, but if your macros operate several workbooks, you'll need to difference when to use each one.
Try this code
Sub Test()
Dim rng As Range
Dim cel As Range
With Sheets("Raw Data")
Set rng = .Range("BC3:BC" & .Cells(Rows.Count, "BC").End(xlUp).Row)
End With
Application.ScreenUpdating = False
For Each cel In rng
If Not SheetExists(cel.Value) Then
Sheets("CC Template").Copy After:=Sheets(Sheets.Count)
With ActiveSheet
.Name = Right(cel.Value, 5)
.Range("B2").Value = cel.Value
End With
End If
Next cel
Sheets("Raw Data").Activate
Application.ScreenUpdating = True
End Sub
Function SheetExists(sheetName As String) As Boolean
On Error Resume Next
SheetExists = (LCase(Sheets(sheetName).Name) = LCase(sheetName))
On Error GoTo 0
End Function
I know this has been asked lot of times but I'm having a trouble with VBA, I am very new to VBA.
I'm working with a single workbook that has a working worksheet. basically I need to sort the Currency column, currently have 14 currencies, I need loop through it (since currency may add through time depending on the customer) then copy the row with the criteria paste it to another sheet with its cell value.
my code below.
Option Explicit
Sub SortCurrency()
Dim rng As Range
Dim xCell As Range
Dim I As Long
Dim J As Long
I = Worksheets("Sheet1").UsedRange.Rows.Count
J = Worksheets("Sheet2").UsedRange.Rows.Count
If J = 1 Then
If Application.WorksheetFunction.CountA(Worksheets("Sheet2").UsedRange) = 0 Then J = 0
End If
Set rng = Worksheets("Sheet1").Range("AB2:AB" & I)
On Error Resume Next
Application.ScreenUpdating = False
For Each xCell In rng
If CStr(xCell.Value) = "USD" Then
Sheets.Add After:=Sheets(Sheets.Count)
Sheets(Sheets.Count).Name = xCell.Value
xCell.EntireRow.Copy Destination:=Sheets(Sheets.Count).Name = xCell.Value.Range("A" & J + 1)
'Sheets.Add After:=Sheets(Sheets.Count)
'Sheets(Sheets.Count).Name = xCell.Value
Application.CutCopyMode = False
J = J + 1
End If
Next
Application.ScreenUpdating = True
End Sub
I basically got the codes from my research, add them up and not coming into the way I wanted. I wanted to keep the header and the values with criteria,
i,e currency column "AB" is USD as per example above, but the problem is it'll be a lot of coding because I have to go through all 14 currencies plus if there will be new currency that will be added,
also I know there is a way of not declaring multiple sheets and just having another new worksheet with the cell value name but I'm having a problem getting it done all at once. if there will be a simpler and powerful code. I am greatly thankful.
you may want to try this code, exploiting Autofilter() method of Range object
Option Explicit
Sub SortCurrency()
Dim currRng As Range, dataRng As Range, currCell As Range
With Worksheets("Currencies") '<--| change "Currencies" to your actual worksheet name to filter data in and paste from
Set currRng = .Range("AB1", .Cells(.Rows.Count, "AB").End(xlUp))
Set dataRng = Intersect(.UsedRange, currRng.EntireRow)
With .UsedRange
With .Resize(1, 1).Offset(, .Columns.Count)
With .Resize(currRng.Rows.Count)
.Value = currRng.Value
.RemoveDuplicates Array(1), Header:=xlYes
For Each currCell In .SpecialCells(xlCellTypeConstants)
currRng.AutoFilter field:=1, Criteria1:=currCell.Value
If Application.WorksheetFunction.Subtotal(103, currRng) - 1 > 0 Then
dataRng.SpecialCells(xlCellTypeVisible).Copy Destination:=GetOrCreateWorksheet(currCell.Value).Range("A1")
End If
Next currCell
.ClearContents
End With
End With
End With
.AutoFilterMode = False
End With
End Sub
Function GetOrCreateWorksheet(shtName As String) As Worksheet
On Error Resume Next
Set GetOrCreateWorksheet = Worksheets(shtName)
If GetOrCreateWorksheet Is Nothing Then
Set GetOrCreateWorksheet = Worksheets.Add(After:=Sheets(Sheets.Count))
GetOrCreateWorksheet.name = shtName
End If
End Function
You're pretty close with what you've got, but there's a few things to note:
On Error Resume Next is normally a bad plan as it can hide a whole lot of sins. I use it in the code below, but only because I immediately deal with any error that might have happened.
xCell.Value.Range("A" & J + 1) makes no sense. Chop out the middle of that line to leave xCell.EntireRow.Copy Destination:=Sheets(Sheets.Count).Range("A" & J + 1)
Rather than checking if the value is a specific currency, you should be taking the value, whatever currency it is, and dealing with it appropriately.
Using J as a counter works for one currency, but when dealing with multiple, it'll be easier to just check where it should go on the fly.
All told, the below code should be close to what you're looking for.
Option Explicit
Sub SortCurrency()
Dim rng As Range
Dim xCell As Range
Dim targetSheet As Worksheet
Dim I As Long
Dim J As Long
I = Worksheets("Sheet1").UsedRange.Rows.Count
J = Worksheets("Sheet2").UsedRange.Rows.Count
If J = 1 Then
If Application.WorksheetFunction.CountA(Worksheets("Sheet2").UsedRange) = 0 Then J = 0
End If
Set rng = Worksheets("Sheet1").Range("AB2:AB" & I)
Application.ScreenUpdating = False
For Each xCell In rng
Set targetSheet = Nothing
On Error Resume Next
Set targetSheet = Sheets(xCell.Value)
On Error GoTo 0
If targetSheet Is Nothing Then
Sheets.Add After:=Sheets(Sheets.Count)
Set targetSheet = Sheets(Sheets.Count)
targetSheet.Name = xCell.Value
xCell.EntireRow.Copy Destination:=targetSheet.Range("A" & J + 1)
Else
xCell.EntireRow.Copy Destination:=targetSheet.Range("A" & targetSheet.Range("A" & Rows.Count).End(xlUp).Row + 1)
End If
Application.CutCopyMode = False
Next
Application.ScreenUpdating = True
End Sub
OK, there's quite a lot going on here... I'm going to try and tackle one problem at a time.
1 - You could do with testing whether a worksheet already exists rather than creating it every time
Assuming you want to do something for each and every currency in your loop, I would suggest not using the if condition you're using at the moment, "if value = "USD"", and instead use the cell value to determine the name of the sheet, whatever the cell value is.
First of all you need a seperate function to test whether the sheet exists, like
Public Function DoesSheetExist(SheetName as String)
On Error Resume Next
Dim WkSheet as WorkSheet
'sets worksheet to be the sheet NAMED the current currency name
Set WkSheet = Sheets(SheetName)
'because of on error resume next, WkSheet will simply be "Nothing" if no such sheet exists
If WkSheet is Nothing Then
DoesSheetExist = False
Else
DoesSheetExist = True
End If
End Function
You can then call this function in your code, and only create new sheets when you need to
2 - The loop itself
So instead, I would suggest your loop probably wants to look more like this:
Dim xSheet as Worksheet 'declare this outside the loop
For Each xCell In rng
If DoesSheetExist(xCell.Value) Then
set xSheet = Sheets(xCell.Value) 'this is the code for if the sheet does exist - sets the sheet by the sheet name rather than index
Else
set xSheet = Sheets.Add After:=Sheets(Sheets.Count)
xSheet.Name = xCell.Value
End if
With this setup, for every currency your loop will either set xSheet to the currency sheet that already exists, or create that sheet. This assumes that you want to do the same thing to all currencies, if not then extra conditions will need adding in
3 - the copy/paste line itself
xCell.EntireRow.Copy Destination:=Sheets(Sheets.Count).Name = xCell.Value.Range("A" & J + 1)
I don't think this code says what you think it does - what this code actually says is "Copy the Entire Row to the last Sheet's name, and make it equal to the range within xCell's Value at A, (J)+1
I think what you actually wanted to say was this:
xCell.EntireRow.Copy Destination:=Sheets(Sheets.Count).Range("A" & J + 1)
However, if you're using the code I gave you above you can instead use this now:
xCell.EntireRow.Copy Destination:=xSheet.Range("A" & J + 1)
In fact, you'd be better off doing that, especially if there is a chance that the sheets already existed and were picked up by DoesSheetExist
Personally I would also rather transfer values over than use copy/paste any day, but that's just an efficiency thing, the above should function fine.
I have a spreadsheet"ProductIDList" and many other spreadsheets. With "ProductIDList",column A is product name and column B is productID. I want to insert the productID to column C of other spreadsheets by matching the Product name in "ProductIDList" and other spreadsheets.
I compose this code but it cannot run.
Please help :-(
Sub InsertProductID()
Dim ws As Worksheet
Dim i As Integer
Dim k As Integer
For Each ws In Worksheets
If ws.Name = "index" Or ws.Name = "ProductIDList" Then GoTo NEXXT
NEXXT:
ws.Activate
For i = 1 To 30000
For k = 1 To 30000
If ws.Cells(i, 2).Value = Sheets("ProductIDList").Cells(k, 1) Then
ws.Cells(i, 3).Value = Sheets("ProductIDList").Cells(k, 2).Value
End If
Next
Next
Next
End Sub
I edited my code. It can run now! But as what you guys said, it runs very very slow.
Sub InsertProductID()
Dim ws As Worksheet
Dim i As Integer
Dim k As Integer
For Each ws In Worksheets
If ws.Name <> "index" And ws.Name <> "ProductIDList" Then
ws.Activate
For i = 1 To 70
For k = 1 To 70
If ws.Cells(i, 2).Value = Sheets("ProductIDList").Cells(k, 1) Then
ws.Cells(i, 3).Value = Sheets("ProductIDList").Cells(k, 2).Value
End If
Next
Next
End If
Next
End Sub
I think that this code will run really slow.
In particular, I don't understand the meaning of following two lines:
If ws.Name = "index" Or ws.Name = "ProductIDList" Then GoTo NEXXT
NEXXT:
If your goal is to skip the sheets named "ProductIDList" and "index", you have - at least - to put your NEXXT label just before the last Next statement. In general, I would avoid to use unconditional jumps, anyway.
What about trying to use some formula functions, like VLOOKUP? In general, they are much faster, but I don't know the requirements of your application.
I am trying to write a vba code to get rid of a row if any word is immediately repeated in same column (column E) but in other row. If that happens, the row to be deleted is the one more on top. Follow an example below. In this case, the row to be dropped are: E6, E10 and E15.
Name of the sheet is test. Columns and F and G are not relevant.
Thanks a lot!
Edit to add code from comments:
Sub delete_duplicates_column_E()
With Sheets("test").Range("A:E")
.Value = .Value
.RemoveDuplicates Columns:=5, Header:=xlYes
End With
End Sub
Just whipped this up, try it:
Sub removeDuplicates()
Range("E2").Select
Do Until ActiveCell.Value = ""
If ActiveCell.Value = ActiveCell.Offset(1).Value Then
ActiveCell.EntireRow.Delete (xlShiftUp)
End If
ActiveCell.Offset(1).Select
Loop
End Sub
When deleting rows it is better to loop back wards:
Sub delete_duplicates_column_E()
Dim ws As Worksheet
Dim lastrow As Long
Dim i As Long
Set ws = Sheets("test")
With ws
lastrow = .Range("E" & .Rows.Count).End(xlUp).Row
For i = lastrow To 2 Step -1
If .Cells(i, 5) = .Cells(i + 1, 5) Then
.Rows(i).Delete
End If
Next i
End With
End Sub
I am very new to VBA and macros in Excel. I have a very large excel spreadsheet in which column A holds dates. I am trying to delete the rows which have a value smaller than a certain date and this is what I have come up with till now..
Sub DELETEDATE()
Dim x As Long
For x = 1 To Cells.SpecialCells(xlCellTypeLastCell).Row
Debug.Print Cells(x, "A").Value
If CDate(Cells(x, "A")) < CDate("01/01/2013") Then
Cells(i, "A").EntireRow.Delete
End If
Next x
Next i
End Sub
I am receiving a Next without For error... can somebody help please?
This lends itself well to using the .AutoFilter property of a Range. The script below contains a comment for each step taken:
Option Explicit
Sub DeleteDateWithAutoFilter()
Dim MySheet As Worksheet, MyRange As Range
Dim LastRow As Long, LastCol As Long
'turn off alerts
Application.DisplayAlerts = False
'set references up-front
Set MySheet = ThisWorkbook.Worksheets("Sheet1")
'identify the last row in column A and the last col in row 1
'then assign a range to contain the full data "block"
With MySheet
LastRow = .Range("A" & .Rows.Count).End(xlUp).Row
LastCol = .Range("A" & .Columns.Count).End(xlToLeft).Column
Set MyRange = .Range(.Cells(1, 1), .Cells(LastRow, LastCol))
End With
'apply autofilter to the range showing only dates
'older than january 1st, 2013, then deleting
'all the visible rows except the header
With MyRange
.AutoFilter Field:=1, Criteria1:="<1/1/2013"
.SpecialCells(xlCellTypeVisible).Offset(1, 0).Resize(.Rows.Count).Rows.Delete
End With
'turn off autofilter safely
With MySheet
.AutoFilterMode = False
If .FilterMode = True Then
.ShowAllData
End If
End With
'turn alerts back on
Application.DisplayAlerts = True
End Sub
Running this code on a simple example (on "Sheet1" in this picture) that looks like this:
Will delete all rows with a date older than 1/1/2013, giving you this result:
To answer your question
I am receiving a Next without For error
The problem is you are trying to loop on i but you haven't opened a For i loop. When you indent the code below any code that invokes a Loop or condition (i.e. If) it becomes obvious
Sub DELETEDATE()
Dim x As Long
For x = 1 To Cells.SpecialCells(xlCellTypeLastCell).Row
Debug.Print Cells(x, "A").Value
If CDate(Cells(x, "A")) < CDate("01/01/2013") Then
Cells(i, "A").EntireRow.Delete 'i has no value so Cells(0, "A") is ??
End If
Next x
Next i 'where is the For i = ... in this code?
End Sub
When writing code I try to:
Enter the end command immediately if it's needed. So type If...Then, hit [ENTER], type End If, hit [HOME], hit [ENTER], hit [UP ARROW] then [TAB] to the right place to write the conditional code so that anyone will be able to read and understand it easily.
Always use Option Explicit at the top of every module to force variable declarations.
a tip about deleting rows based on a condition
If you start at the top and work down, every time you delete a row your counter will effectively move to the cell two rows below the row you deleted because the row immediately below the deleted row moves up (i.e. it is not tested at all).
The most efficient way is to loop up from the bottom or your rows:
Sub DELETEDATE()
Dim x As Long
For x = [a1].SpecialCells(xlCellTypeLastCell).Row To 1 Step -1
Debug.Print Cells(x, "A").Value
If CDate(Cells(x, "A")) < CDate("01/01/2013") Then
Cells(x, "A").EntireRow.Delete 'changed i to x
End If
Next x
End Sub
This way, the next row you want to test has been preserved - you've only moved the row below up by 1 and you've tested that row earlier.
Please try with this
Sub DELETEDATE()
Dim x As Long
last = Range("A65536").End(xlUp).Row
For x = 1 To last
Debug.Print Cells(x, "A").Value
check:
If x <= last Then
If Trim(CDate(Cells(x, "A"))) <= Trim(CDate("7/29/2013")) Then
last = last - 1
Cells(x, "A").EntireRow.Delete
GoTo check
End If
End If
Next x
End Sub
You have an additional Next i for some reason in your code as highlighted by the debugger. Try the below:
Sub DELETEDATE()
Dim x As Long
For x = 1 To Cells.SpecialCells(xlCellTypeLastCell).Row
Debug.Print Cells(x, "A").Value
If CDate(Cells(x, "A")) < CDate("01/01/2013") Then
Cells(i, "A").EntireRow.Delete
End If
Next x
End Sub