Already for some days, I'm searching the internet to find the correct code/help for my application.
The situation: If a certain product for a certain customer is done, column 9 give "Ready". When this happens, the whole row has to move to sheet 2 in a kind of 'history'-list and disappear out of the 'up-to-date'-list.
My code is the next:
Sub MoveDelete()
Dim i As Integer
Dim y As Integer
Application.ScreenUpdating = False
i = ActiveSheet.UsedRange.Rows.Count
For y = i To 1 Step -1
If Cells(y, 9).Value = "Mag weg" Then
Cells(y, 9).EntireRow.Cut Worksheets(2).Cells(i, 1)
Cells(y, 1).EntireRow.Delete
i = i + 1
End If
Next
End Sub
This code is working but gives other problems. Suppose today my range is 40 and 3 rows should be moved to the second worksheet, they are placed on row 40,39 and 38 (instead of 1,2,3 which would be better). But for example, tomorrow I add 5 rows in the up-to-date list and 4 old rows can be removed again, it will overwrite the previous ones (but I would like to have them on 4,5,6 and 7).
My goal is to have a list that I can update every day so the production line has a clear view of the workload and on the second page a list with all products/customerinformation that are done the last month.
I hope somebody can help me out here. If there are more questions, feel free to ask! Thanks a lot!
You can append the new moved rows to the end of what already exists in sheet2.
Sub MoveDelete()
Dim i As Integer, y As Integer, j as Integer
Application.ScreenUpdating = False
'Find first free row in sheet2
j = Worksheets(2).cells(Rows.Count, 9).End(xlUp).Row + 1
i = ActiveSheet.cells(Rows.Count, 9).End(xlUp).Row
For y = i To 1 Step -1
If Cells(y, 9).Value = "Mag weg" Then
Rows(y).Copy Worksheets(2).Rows(j)
Rows(y).EntireRow.Delete
j = j + 1
End If
Next
Application.ScreenUpdating = True
End Sub
Related
I have a dataset that includes 9 columns. I want to check each row to see if the last 3 columns are empty. If all 3 are empty, I want to delete the row. I'm currently trying to do this in VBA, but I'm a programming newb and find myself completely overwhelmed.
The pseudocode that I've written is as follows:
For Row i
If(Col 1 & Col 2 & Col 3) = blank
Then delete Row i
Move on to next Row
I'd go like follows
Dim iArea As Long
With Range("E:G") '<--| change "E:G" to your actual last three columns indexes
If WorksheetFunction.CountBlank(.Cells) < 3 Then Exit Sub
With .SpecialCells(xlCellTypeBlanks)
For iArea = .Areas.Count To 1 Step -1
If .Areas(iArea).Count Mod 3 = 0 Then .Areas(iArea).EntireRow.Delete
Next
End With
End With
Assuming you have at least one row that is always filled out, you can use the following:
Dim LR as Long
Dim i as Integer
LR = Cells(Sheets("REF").Rows.Count,1).End(xlUp).Row
For i = 1 to 9
If Range(Cells(LR-3,i),(Cells(LR,i)).Value="" Then
Columns(i).Delete
Else:
End If
Next i
This works by defining the last row as LR, and defining a variable as i. You will check column "i" to determine if the last 3 rows of the column are "", aka it's blank; one might try to use ISBLANK(), but that cannot work for an array. If this is true, then you will delete the column, i. The code will then move to the next i. The FOR LOOP using i starts at 1 and goes to 9, which corresponds to starting at column 1 (A) and ending at column 9 (I).
Edit:
I appear to have misread which was supposed to be empty and which is supposed to be deleted, in terms of columns/rows... this code would be re-written as:
Dim LR as Long
Dim i as Integer
LR = Cells(Sheets("REF").Rows.Count,1).End(xlUp).Row
For i = LR to 2 Step -1 'Assumes you have headers in Row1
If AND(ISBLANK(Cells(i,7)),ISBLANK(Cells(i,8)),ISBLANK(Cells(i,9)) Then
Rows(i).Delete
End If
Next i
Significant changes are checking is each of the 3 last columns in the row are empty, ISBLANK(), changing that a row gets deleted if the condition is met, and changing what to loop through.
Here's another answer, assuming your last three column starts on "G","H","I".
Sub DeleteRowWithLastThreeColumnsBlank()
Dim N As Long, i As Long
N = Cells(Rows.Count, "A").End(xlUp).Row
For i = 1 To N
If Cells(i, "G").Value = "" And Cells(i, "H").Value = "" And Cells(i, "I").Value = "" Then
Rows(i).EntireRow.Delete
N = Cells(Rows.Count, "A").End(xlUp).Row
End If
Next i
End Sub
I've found a couple threads with similar titles but weren't really what I am looking to do. What I'm trying to do is go through the list of numbers in Col A, and calculate the time difference using NetworkDays for the first instance the number appears in Col B ' Received On ' and the last instance the number appears in Col C ' Processed On '. After the NetworkDays calculation is done I'd like to put that value repeating in Col D on every respective row. The number of times a value will appear in Col A constantly varies, and Col A itself is several thousand lines long and constantly growing. Once that is done I need to loop through all the other different sets of numbers in Col A and repeat the process. As an example, ***39430 first appears on Row 2 and last appears on Row 7. Using Networkdays(B2,C7) gives 11 days, and so forth. After that move onto ***39383. Sample below.
Sample data
Below is the code I have so far. From the sample above I have to put a blank row under ***39430 in order to get the code to work, otherwise it just continues on to the bottom of the list and calculates that difference (not what I want obviously). What I'm stumped on is how to tell the loop to restart whenever the value changes in Col A and then continue on. I suspect it might be something close to Do Until ActiveCell.Value <> Activecell.Offset(-1,0).Value but I can't quite figure it out. Also how to get the Networkdays value to repeat on every respective row.
Dim counter As Integer
Dim CycleTime As Long
counter = 0
Do Until ActiveCell.Value = ""
counter = counter + 1
ActiveCell.Offset(1, 0).Select
Loop
'Gives the number of rows to offset
MsgBox counter
'Shows the correct number of days difference
MsgBox WorksheetFunction.NetworkDays(Range("B2"), Range("B2").Offset(counter - 1, 1))
CycleTime = WorksheetFunction.NetworkDays(Range("B2"), Range("B2").Offset(counter - 1, 1))
Range("D2").Value = CycleTime
Any help would be greatly appreciated. Thanks in advance.
Update
After using the code provided for a couple of weeks I've noticed a complication that I had not thought of before. Previously, I had thought that there was always only one output doc for each input doc (not considered in scope of original question), however as shown in Sample-New image in the top box there can be more than one output doc per input doc. For the new screenshot below I've included two additional columns, Col. C 'Output Doc #' and Col. D 'Output Doc Created On'. What I'd like to be able to do, amending the code that #YowE3K provided below, is to nest another loop that goes through Col. D 'Output Doc #' and uses NetworkDays to calculate the difference from B1 and D1 for the first group, and then B1 and D8 for the second group. As it is now, the code isn't written to handle the change and calculates everything as shown in Column F, with the ideal code resulting in Column G. The second box (in dark blue) shows a typical example where the code performs perfectly. Loops are something I'm struggling with to understand and not really sure how to even take a stab at this. Any comments to the code in a response would be very helpful. Thanks in advance.
Sample - New
The following code loops using endRow as the loop "counter".
startRow is set to the row containing the start of the current "Doc Number", and endRow is incremented until it is pointing at the last row for that "Doc Number".
Once endRow is pointing at the correct place, CycleTime is calculated and written to column D of each row from startRow to endRow. startRow is then set to point to the beginning of the next "Doc Number".
The loop ends when a blank cell is found in column A.
Sub Calc()
Dim startRow As Long
Dim endRow As Long
Dim CycleTime As Long
startRow = 2
endRow = 2
Do
If Cells(startRow, "A").Value <> Cells(endRow + 1, "A").Value Then
CycleTime = WorksheetFunction.NetworkDays(Cells(startRow, "B"), Cells(endRow, "C"))
Range(Cells(startRow, "D"), Cells(endRow, "D")).Value = CycleTime
startRow = endRow + 1
End If
endRow = endRow + 1
If Cells(endRow, "A").Value = "" Then
Exit Do
End If
Loop
End Sub
Edited to keep track of the first and last "Approved" record, and only update column D if one is found:
Sub Calc()
Dim startRow As Long 'Start of the Doc Number
Dim firstRow As Long 'First "approved" row
Dim lastRow As Long 'Last "approved" row
Dim endRow As Long 'End of the Doc Number
Dim CycleTime As Long
startRow = 2
endRow = 2
firstRow = -1
lastRow = -1
Do
If Cells(endRow, "Q").Value = "Approved" Then
'Found an "Approved" record
'Set the first row if not already set
If firstRow = -1 Then
firstRow = endRow
End If
'Set the last row (will replace this if we find another record)
lastRow = endRow
End If
If Cells(startRow, "A").Value <> Cells(endRow + 1, "A").Value Then
If firstRow > 0 Then ' (If it is -1 then we never found an "Approved" record)
CycleTime = WorksheetFunction.NetworkDays(Cells(firstRow, "B"), Cells(lastRow, "C"))
Range(Cells(startRow, "D"), Cells(endRow, "D")).Value = CycleTime
End If
'Set up for next Doc Number
startRow = endRow + 1
firstRow = -1
lastRow = -1
End If
'Go to next row
endRow = endRow + 1
'Exit when we hit a blank Doc Number
If Cells(currentRow, "A").Value = "" Then
Exit Do
End If
Loop
End Sub
So here is what I am starting with:
And here is what I would like it to look like when it is done:
I think what it needs to do is:
1.) Go through the Route column
2.) Find the duplicate values
3.) Select all the rows between the first duplicate route value and the last
4.) Merge all the duplicate cells in that range
5.) Repeat until you get to the last row of data.
My problems is that I really just don't know enough about vba to do what I want it to do and I haven't had any luck with finding some code that already does this. I'll keep trying, but I would welcome any assistance/insight that you wonderful people on this site can provide.
So I moved the route into column 1 and got my macro to work with this code:
Sheets("Master").Select
With ActiveSheet
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
End With
Dim KRng As Range, Kxcell As Range
Dim KxRows As Integer
Dim KeyRng As Range
Set KeyRng = Range("A4:A" & LastRow)
KeyRng.Select
'Application.ScreenUpdating = False
'Application.DisplayAlerts = False
KxRows = KeyRng.Rows.Count
For Each KRng In KeyRng.Columns
For c = 1 To KxRows - 1
For d = c + 1 To KxRows
If KRng.Cells(c, 1).Value <> KRng.Cells(d, 1).Value Then
Exit For
End If
Next
KeyRng.Parent.Range(KRng.Cells(c, 1), KRng.Cells(d - 1, 1)).Select
With Selection
ActiveCell.Resize(d - c, 60).Select
End With
Call MergeSameCell
KeyRng.Parent.Range(KRng.Cells(c, 1), KRng.Cells(d - 1, 1)).Select
c = d - 1
Next
Next
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
Now my question is, how do I get it to select the 60 columns to the right but skip columns 8 through 12? I'll keep researching and see what I can come up with, but I'd welcome a simple or elegant answer.
I have two sheet tabs.i.e. Raw Data and Overview
I was looking for code which would copy and paste data in the Overview tab based on the names in Column B and dates in row 3:3.
The table in Raw Data tab has names in column A, dates in Column B and Value in Column C
The table in Overview looks like this
01/04/2015 02/04/2015 03/04/2015 04/04/2015 05/04/2015
a
b
c
d
I understand that there are formulas like Vlookups, Index, sumifs but I would prefer the solution in VBA as the data is extensive
As a matter of example only, please check the code below, it has sections that create things for you. It should work for your problem, but certainly is not using the best practices specially while looking at the performance side of the problem.
To run this code, you have to check and modify the worksheet names in the two code lines starting with "Set" and change the column and row indexers to fit your needs.
Also, it is important to say that, if you have repeated values on your first two columns, this procedure might not work as expected.
Sub DoYourJob()
Dim x As Integer
Dim y As Integer
Dim z As Integer
Dim sourceWorksheet As Worksheet
Dim targetWorksheet As Worksheet
Set sourceWorksheet = ThisWorkbook.Worksheets("YourSourceWorksheetName")
Set targetWorksheet = ThisWorkbook.Worksheets("YourTargetWorksheetName")
Dim existing As Boolean
'Let the macro read an create the table
'Creating the rows
For x = 2 To sourceWorksheet.Cells(sourceWorksheet.Rows.Count, 1).End(xlUp).Row
existing = False
For y = 2 To targetWorksheet.Cells(targetWorksheet.Rows.Count, 1).End(xlUp).Row
If targetWorksheet.Cells(y, 1).Value = sourceWorksheet.Cells(x, 1).Value Then
existing = True
Exit For
End If
Next y
If Not existing Then
targetWorksheet.Cells(targetWorksheet.Cells(targetWorksheet.Rows.Count, 1).End(xlUp).Row + 1, 1).Value = sourceWorksheet.Cells(x, 1).Value
End If
Next x
'Creating the columns
For x = 2 To sourceWorksheet.Cells(sourceWorksheet.Rows.Count, 1).End(xlUp).Row
existing = False
For y = 2 To targetWorksheet.Cells(1, targetWorksheet.Columns.Count).End(xlToLeft).Column
If targetWorksheet.Cells(1, y).Value = sourceWorksheet.Cells(x, 2).Value Then
existing = True
Exit For
End If
Next y
If Not existing Then
targetWorksheet.Cells(1, targetWorksheet.Cells(1, targetWorksheet.Columns.Count).End(xlToLeft).Column + 1).Value = sourceWorksheet.Cells(x, 2).Value
End If
Next x
'Iterate to fill the table
For z = 1 To sourceWorksheet.Cells(sourceWorksheet.Rows.Count, 1).End(xlUp).Row
For y = 2 To targetWorksheet.Cells(targetWorksheet.Rows.Count, 1).End(xlUp).Row
If targetWorksheet.Cells(y, 1).Value = sourceWorksheet.Cells(z, 1).Value Then
For x = 2 To targetWorksheet.Cells(1, targetWorksheet.Columns.Count).End(xlToLeft).Column
If targetWorksheet.Cells(1, x).Value = sourceWorksheet.Cells(z, 2).Value Then
targetWorksheet.Cells(y, x).Value = sourceWorksheet.Cells(z, 3).Value
Exit For
End If
Next x
Exit For
End If
Next y
Next z
End Sub
If you have trouble understanding or using the code, please leave a comment.
Alright for this project I am trying to take columns headers and combine them in row headers in one column. For instance
There a column header plant store it has rows with corresponding data tr1, tr2, tr3.
I want to make one full column with the data so it appears like this "plant store tr1", "Plant store tr2" etc...
this is the code I have so far.
J represents an arbitrary range that I want all the data to fill
X represents the location of all the tr1, tr2s, I want added to the end of plant store
plant store is located at J15 in detailed ratings.
Sub Double_column_method()
Dim J As Variant
Dim x As Variant
Set J = Range("A6:A400")
Sheets("Sheet2").Select
Range("A6").Select
For x = Sheets("Detailed Ratings").Range("J15") To Sheets("Detailed Ratings").Range("BQ15")
If J.Value <> "" Then J.Value = x&(Sheets("Detailed Ratings")).Range("I16")
Next
End Sub
Thank you any help is appreciated.
If I'm reading your post correctly, I think the following is what you need. It can be done without VBA. Type the formula in yellow and copy down/across.
Sub test()
Row = Cells(Rows.Count, "A").End(xlUp).Row
r = Row - 15
Column = Cells(16, Columns.Count).End(xlToLeft).Column
c = Column - 9
For i = 1 To r
For J = 1 To c
n = n + 1
Cells(n, "BU") = Cells(i + 15, "I") & Cells(15, J + 9)
Next J
Next i
This solved it for me, produced a clean list of all my headings combined.