Thanks to a previous post and some excellent direction I was able to create successfully working code for my needs. However, the table/data has changed a bit and I have not yet reached my ultimate goal of iterating the paste function based on another cell's value. I have seen this post on SO but it has not helped me. I found other resources on using loops in Excel VBA and created the very simple Do While code you see below.
My problem: I cannot get the code to stop looping when it reaches the value from Column F. It finds the first available case and outputs the correct information endlessly without stopping at n value and moving on.
Here is a look at the data table:
A B C D E F
R1 Name Num Status #Orig #Act #Rem
R2 ABC 032 Complete 22 0 11
R3 LMN 035 In Prog 25 21 4
Here is my code:
Sub Copy_Pending_Status()
Dim srcrange As Range
Dim wb As Workbook
Dim ws1 As Worksheet, ws2 As Worksheet
Dim i As Integer
Set wb = ActiveWorkbook
Set ws1 = wb.Worksheets("SIS Agregate")
Set ws2 = wb.Worksheets("Center Detail")
Set srcrange = ws2.Range("C2:C61")
For Each Row In srcrange.Cells
Select Case Row.Value
Case "In Progress"
Do While i <= Row.Offset(0, 3).Value
Set LastCell = ws1.Cells(ws1.Rows.Count, "C").End(xlUp).Offset(1)
LastCell.Offset(0, 0).Value = Row.Offset(0, -2).Value
LastCell.Offset(0, 12).Value = Row.Offset(0, -1).Value
LastCell.Offset(0, 4).Value = "Not Yet Scanned"
Loop
Case "Complete"
Do While i <= Row.Offset(0, 3).Value
Set LastCell = ws1.Cells(ws1.Rows.Count, "C").End(xlUp).Offset(1)
LastCell.Offset(0, 0).Value = Row.Offset(0, -2).Value
LastCell.Offset(0, 12).Value = Row.Offset(0, -1).Value
LastCell.Offset(0, 4).Value = "Purged"
Loop
End Select
Next Row
End Sub
I have tried setting the Do While i <= Row.Offset(0, 3).Value to (0,3) (0,4) and (0,6) as I am not sure if it is counting the number of columns from "A" as one, "C" as one, or "C" as zero and offset is three (to the right).
I want to note that eliminating the Do While and Loop lines of code from each case make this function correctly, but only once per row, per case - as opposed to however many times Column F indicates.
Have I oversimplified this and am missing some obvious key information? What change do I need to make to get this little loop to function correctly?
Nothing within your loops changes the value of i, and so the "Do While" conditions are always met. You need to iterate through values of i so that eventually the conditions will not be met. At the end of each loop, add:
i = i + 1
This will allow it to count how many times the loop has been run and stop after a set number of iterations based on Column F.
You'll also want to re-set i to zero in between each row. Do this between "End Select" and "Next Row":
End Select
i = 0
Next Row
Related
So I have been working on this little piece of code for a couple of days now and have hit a snag that I just cannot figure out. Basically I have a nested for loop that is supposed to take values from one Sheet and put them in a data sheet so that those value can be saved and averaged out over time.
I want the data from the cells M5 - M35 to get put into the data sheet like this: from left to right A3 - AC200, but I also want the loop to stop once the M5 - M35 range runs out of values and when the user next pushes the button to store data I want the loop to start on the next line down.
So This Spreadsheet is for my work, it is for a Butchery Yield Test and I want it to have it's owned database stored on a hidden sheet that will be averaged out over time so I or others can come back to it and update it every few months to make the averages more accurate and to get a better understanding of the profitability of certain cuts of meat.
I have tried setting the loop values back to their starting values once the loop has filled out all the data which worked and I thought I'd solved the issue until I ran the test multiple time and found that the first and second time work as expected from the third onwards however it doesn't start the loop down at the next row it just continues through the range
Sub subData1()
Dim rng As Range
Dim rcell As Range
Dim ws As Worksheet
Dim Tws As Worksheet
Set Tws = Worksheets("Test")
Set ws = Worksheets("data")
For i = 3 To 200 'range is from cell A3 - A200
'if start cell already has value go down a row
If ws.Cells(i, 1).Value <> "" Then
i = i + 1
End If
'set the range for data sheet
Set rng = ws.Range(ws.Cells(i, 1), ws.Cells(i, 30).End(xlToRight))
For f = 5 To 35
For Each rcell In rng 'loop through each cell in data sheet range
If rcell.Value = "" Then 'if cell is blank input data
If Tws.Cells(f, 13).Value <> "" Then
'Check the selected Cell has a value
rcell.Value = Tws.Cells(f, 13).Value
f = f + 1
End If
Else
If f > 5 Then
MsgBox "Data Storage Updated", , "Data Storage"
f = 5
Exit Sub
'Else
'MsgBox "Value Must Be Greater Than Zero", , f
'f = 5
'Exit Sub
End If
End If
Next
Next
Next
End Sub
The reason it's working the first and second time is because of this line
If ws.Cells(i, 1).Value <> "" Then
i = i + 1
End If
But, if you'll notice, it's only running once for each iteration. Which means that on a blank sheet, it will evaluate false on the first iteration of the first run and continue, on the first iteration of the second run, it will evaluate true and move down one row to row 4, but on the first iteration of the third run it will also evaluate true and move down to row 4 and then place data starting at ws.Range(ws.Cells(i, 1), ws.Cells(i, 30).End(xlToRight))
You need to change your If-End If to a function that will retrieve the last used row in Column A of your data sheet. Additionally, you probably don't need your outer For-Next loop since that's looping through your output sheet and would output the same M5:M35 values for every single row.
If I understand your needs correctly, I believe you could utilize this to accomplish what you're looking for
Dim rng As Range
Dim ws As Worksheet
Dim Tws As Worksheet
Dim endRow As Long
Set Tws = Worksheets("Test")
Set ws = Worksheets("data")
endRow = ws.Range("A" & Rows.Count).End(xlUp).Row + 1
Set rng = ws.Cells(endRow, 1)
For f = 5 To 35
If Tws.Cells(f, 13).Value <> "" Then
rng.Value = Tws.Cells(f, 13).Value
Set rng = rng.Offset(0, 1)
End If
Next
With this, every sequential button click would insert data at a new row, looping through Tws.Cells(f,13) and placing that value in the right-most column by incrementally setting the range.
I'm currently looking for a code to improve my Dashboard. Actually, I need to know how to use a loop in a column X who will affect a column Y (cell on the same line).
To give you an example:
Column A: I have all Production Order (no empty cell)
Column B: Cost of goods Sold (Sometimes blank but doesn't matter)
I actually pull information from SAP so my Column B is not in "Currency".
The action should be:
If A+i is not empty, then value of B+i becomes "Currency".
It's also for me to get a "generic" code that I could use with other things.
This is my current code...
Sub LoopTest()
' Select cell A2, *first line of data*.
Range("A2").Select
' Set Do loop to stop when an empty cell is reached.
Do Until IsEmpty(ActiveCell)
ActiveCell.Offset(0, 1).Style = "Currency"
ActiveCell.Offset(1, 0).Select
Loop
End Sub
Another example, getting Last Row, in case your data contains any blank rows.
Sub UpdateColumns()
Dim wks As Worksheet
Dim lastRow As Long
Dim r As Long
Set wks = ActiveSheet
lastRow = ActiveSheet.Cells.SpecialCells(xlLastCell).Row
For r = 2 To lastRow
If wks.Cells(r, 1) <> "" Then
wks.Cells(r, 2).NumberFormat = "$#,##0.00"
End If
Next r
End Sub
I can see I was a little slower than the others, but if you want some more inspiration, heer is a super simple solution (as in easy to understand as well)
Sub FormatAsCurrency()
'Dim and set row counter
Dim r As Long
r = 1
'Loop all rows, until "A" is blank
Do While (Cells(r, "A").Value <> "")
'Format as currency, if not blank'
If (Cells(r, "B").Value <> "") Then
Cells(r, "B").Style = "Currency"
End If
'Increment row
r = r + 1
Loop
End Sub
Try the following:
Sub calcColumnB()
Dim strLength As Integer
Dim i As Long
For i = 1 To Rows.Count
columnAContents = Cells(i, 1).Value
strLength = Len(columnAContents)
If strLength > 0 Then
Cells(i, 2).NumberFormat = "$#,##0.00"
End If
Next i
End Sub
Explanation--
What the above code does is for each cell in Column B, so long as content in column A is not empty, it sets the format to a currency with 2 decimal places
EDIT:
Did not need to loop
Here's a really simply one, that I tried to comment - but the formatting got messed up. It simply reads column 1 (A) for content. If column 1 (A) is not empty it updates column 2 (B) as a currency. Changing active cells makes VBA more complicated than it needs to be (in my opinion)
Sub LoopTest()
Dim row As Integer
row = 1
While Not IsEmpty(Cells(row, 1))
Cells(row, 2).Style = "Currency"
row = row + 1
Wend
End Sub
I've been using Columns(2).Copy Destination:=Columns(1) provisionally to offset all cells that contain "x" one column to the left, however it seems to be very memory consuming and not very reliable as I can't choose to offset only "x" values.
Is there any way I can make only the cells on which this contition was met to be offset, and on a more efficient way?
Similar to the below answer, but with a For-Each loop and for the whole range:
Sub MoveOver()
Dim rng As Range
Dim c As Range
Set rng = ThisWorkbook.Worksheets("Sheet1").Range("B:B")
For Each c In rng
If c.Value = "x" Then c.Offset(0, -1) = c.Value
Next c
End Sub
you would probably want to try something like this
For i = 1 To 100
If ActiveSheet.Cells(i, 2).Value = "x" Then
ActiveSheet.Cells(i, 1).Value = ActiveSheet.Cells(i, 2).Value
End If
Next
just set the 100 for however many rows you have. I'm not even sure this would run any faster than what you have. Unless I am missing your goal here.
and if you want to go through all cells in the sheet
For Each rcell In ActiveSheet.Cells
If recll.Column >= 1 And rcell.Value = "x" Then
ActiveSheet.Cells(rcell.Row, rcell.Column - 1).Value = ActiveSheet.Cells(rcell.Row, rcell.Column).Value
End If
Next
but this one would presumably take a really long time. Ideally you should use nested loops if you know the last row and column you are using. This way you only iterate of cells that you believe contain data.
I'm trying to find an easy way to get rid of 'bad' rows in my worksheet, which has 3780 rows. Instead of scanning through and deleting each rows every time, which is time consuming, I was wondering if there was an easier way?
Perhaps by making a macro that highlights cells in a column range (A-L) every time it finds the bad value (e.g. 'Apple') in a cell located in every row.
Something along the lines of:
If =ISTEXT() then delete row
I hope this makes sense, let me know if not.
This small macro will search for the presence of apple in any cell in columns A through L and delete that row:
Sub KillBadApple()
Dim rng As Range
Set rng = Intersect(ActiveSheet.UsedRange, Range("A:L"))
nLastRow = rng.Rows.Count + rng.Row - 1
nFirstRow = rng.Row
For i = nLastRow To nFirstRow Step -1
exam = ""
For j = 1 To 12
exam = exam & Chr(1) & Cells(i, j).Text
Next j
exam = LCase(exam)
If InStr(exam, "apple") > 0 Then
Cells(i, j).EntireRow.Delete
End If
Next i
End Sub
I am cycling through values on a pending data list and then updating a master list if any of those values are new. The pending list will normally have 100-200 rows of data and each row will have about 10 variables that it will need to make sure are updated on the master list. The Master list is about 10,000 rows.
I have written code that will loop through each row of the pending list, assign values to variables and then perform a find on the master list looking for a matching record and then update it accordingly. My code works fine and does exactly what I want but the processing time is about 4 minutes and that's 3 minutes and 50 seconds longer than the people that use it are willing to allow without complaining.
Is there alternative coding that I could use to help decrease processing time?
The code I have is very long and so I am not going to paste it all here but instead paste snip-its of it so you can have an idea of what I am currently doing:
Application.Screenupdating = False
Applicaiton.Enableevents = False
Application.Calculation = xlCalculationManual
PendingBRow = ThisWorkbook.Sheets("PendingLog").Range("A65000").End(xlUp).Row
MasterBRow = ThisWorkbook.Sheets("MasterLog").Range("A65000").End(xlUp).Row
For D = 2 To PendingBRow
With ThisWorkbook.Sheets("PendingLog").Range("A" & D)
PendingRecordNumber = .Value
PendingIR = .offset(0, 5).Value
PendingVal = .offset(0, 6).Value
End With
With ThisWorkbook.Sheets("MasterLog").Range("B2:B" & MasterBRow)
Set c = .Find(PendingRecordNumber, LookIn:=xlValues)
If Not c Is Nothing Then
firstAddress = c.Address
Do
DaysSinceLastWorkedStatic = c.offset(0, 22).Value
MasterIRValue = c.offset(0, 16).Value
If PendingIR <> 0 Then
If PendingIR <> MasterIRValue Then
c.offset(0, 16).Value = PendingIR
DaysSinceLastWorkedStatic = 0
c.offset(0, 22).Value = DateVal
End If
End If
c.offset(0, 24).Value = POorLA
c.offset(0, 25).Value = FinalizedFlag
Set c = .FindNext(c)
Loop While Not c Is Nothing And c.Address <> firstAddress ' in rare cases a record number could be duplicated on the master list.
end if
end with
ThisWorkbook.Sheets("PendingLog").Range("A" & D).offset(0, 15).Value = DaysSinceLastWorkedStatic
Next D
One alternative I had considered was to filter the master list by the record number and update the visible row only and then unfilter for each record number on the pending list. I have not yet tested this method.
Could this method be better than what I have?
So I dont know if this will be an answer but I think this might at least give you a look at another type of find/update code.
This is used to update the times people are scheduled to work
In this example I have a Row A with Names B with Times. I paste the updated Name and Time in rows H and I. Some times its all 98 some times it just 5 and this program looks at the list finds the name and takes the time from I and writes it over its corresponding time in B.
Option Explicit
Sub Update_Holiday()
Dim ws As Worksheet
Dim SrcRng As Range
Dim schRng As Range
Dim c As Range
Dim search As Range
Set ws = ThisWorkbook.Sheets(3)
Set SrcRng = ws.Range("H2:H98")
Set schRng = ws.Range("A2:A98")
For Each c In SrcRng
Set search = schRng.Find(c.Value, LookIn:=xlValues, SearchDirection:=xlNext)
If Not search Is Nothing Then
c.Offset(, 1).Copy search.Offset(, 1)
End If
Next c
End Sub