This code copies the entire row to another when the word 'ordered' is in a certain column.
However, I need to adapt this code to not copy the entire row for another function but requires only copying columns A:J over into the next sheet but I'm having difficulty achieving this.
Sub MovingOrderedItems()
Dim xRg As Range
Dim xCell As Range
Dim X As Long
Dim Y As Long
Dim Z As Long
X = Worksheets("Engineer-Items to be ordered").UsedRange.Rows.Count
Y = Worksheets("Admin").UsedRange.Rows.Count
If Y = 1 Then
If Application.WorksheetFunction.CountA(Worksheets("Admin").UsedRange) = 0 Then Y = 0
End If
Set xRg = Worksheets("Engineer-Items to be ordered").Range("N3:N" & X)
On Error Resume Next
Application.ScreenUpdating = False
For Z = 1 To xRg.Count
If CStr(xRg(Z).Value) = "ordered" Then
xRg(Z).EntireRow.Copy Destination:=Worksheets("Admin").Range("A" & Y + 1)
xRg(Z).EntireRow.Delete
If CStr(xRg(Z).Value) = "ordered" Then
Z = Z - 1
End If
Y = Y + 1
End If
Next
Application.ScreenUpdating = True
End Sub
There's probably a more elegant way to do this, but you can replace
xRg(Z).EntireRow.Copy Destination:=Worksheets("Admin").Range("A" & Y + 1)
With
Range(xRg(Z).EntireRow.Cells(1, 1), xRg(Z).EntireRow.Cells(1, 10)).Copy Destination:=Worksheets("Admin").Range("A" & Y + 1)
Related
I have a table in an active worksheet.
I am trying to:
Scan Columns(A:M) of Row 6 to see if all cells are empty
If yes, then scan Columns (N:R) of Row 6 to see if all cells are empty
If 2. is false, then copy above row's Columns (A:I) in Row 6
Repeat 1-3 but on Row 7
This process should repeat until the rows of the table end.
I would like to incorporate ActiveSheet.ListObjects(1).Name or something similar to duplicate the sheet without having to tweak the code.
How I can make this as efficient and as risk free as possible? My code works but it's really too much.
Sub CopyPasteRow()
Dim lr As Long
Dim x As Long
Dim y As Long
Dim a As Long
lr = Cells(Rows.Count, 1).End(xlUp).Row
a = 0
For x = 6 To lr
For y = 1 To 13
If Not IsEmpty(Cells(x, y)) Then
a = a + 1
End If
Next y
If a = 0 Then
For y = 14 To 18
If Not IsEmpty(Cells(x, y)) Then
a = a + 1
End If
Next y
Else
a = 0
End If
If a <> 0 Then
For y = 1 To 13
Cells(x, y).Value = Cells(x - 1, y).Value
Next y
End If
a = 0
Next x
End Sub
This is the final code based on #CHill60 code. It got me 99% where I wanted.
Sub CopyPasteRow()
Dim lr As Long
Dim x As Long
Dim a As Long
Dim r As Range, r2 As Range, r3 As Range
lr = Cells(Rows.Count, 1).End(xlUp).Row
For x = 6 To lr
'check columns A to M for this row are empty
Set r = ActiveSheet.Range("A" & CStr(x) & ":M" & CStr(x))
'check columns N to R for this row are empty
Set r2 = ActiveSheet.Range("N" & CStr(x) & ":R" & CStr(x))
If WorksheetFunction.CountA(r) = 0 And WorksheetFunction.CountA(r2) <> 0 Then
'copy the data into columns A to M
Set r3 = ActiveSheet.Range("A" & CStr(x) & ":I" & CStr(x))
r3.Value = r3.Offset(-1, 0).Value
End If
Next x
End Sub
Instead of looking at individual cells, look at Ranges instead. Consider this snippet of code
Sub demo()
Dim x As Long
For x = 6 To 8
Dim r As Range
Set r = Sheets(1).Range("A" & CStr(x) & ":M" & CStr(x))
Debug.Print r.Address, MyIsEmpty(r)
Next x
End Sub
I have a function for checking for empty ranges
Public Function MyIsEmpty(rng As Range) As Boolean
MyIsEmpty = WorksheetFunction.CountA(rng) = 0
End Function
I use this because the cell might "look" empty, but actually contain a formula.
Note I've explicitly said which sheet I want the Cells from - users have a habit of clicking places other than where you think they should be! :laugh:
Edit after OP comment:
E.g. your function might look like this
Sub CopyPasteRow()
Dim lr As Long
Dim x As Long
Dim a As Long
Dim r As Range, r2 As Range
lr = Cells(Rows.Count, 1).End(xlUp).Row
For x = 6 To lr
a = 0
'check columns A to M for this row are empty
Set r = Sheets(1).Range("A" & CStr(x) & ":M" & CStr(x))
If Not MyIsEmpty(r) Then
a = a + 1
End If
If a = 0 Then
'check columns N to R for this row are empty
Set r2 = Sheets(1).Range("N" & CStr(x) & ":R" & CStr(x))
If Not MyIsEmpty(r2) Then
a = a + 1
End If
Else
a = 0
End If
If a <> 0 Then
'copy the data into columns A to M
'You might have to adjust the ranges here
r.Value = r2.Value
End If
Next x
End Sub
where you have a source range and a target range - you appear to be putting the values in the previous row so my value of r is probably wrong in this example - you could use r.Offset(-1,0).Value = r2.Value
I'm also not sure what you are trying to do with the variable a If that is meant to be a "flag" then consider using a Boolean instead - it only has the values True or False
I am trying to copy the entry forms I select from the master list to a different worksheet. The idea is that it goes down a condensed list of names without details. Looks at what I have selected. Copies the selected entry form and pastes it in a new place to generate a list that only contains the entry forms I need. I can't tell if the loop is working properly because the paste function at the end isn't working.
Sub BidList()
'Sets unique terms used throught this code
Dim wQuick As Worksheet, wMaster As Worksheet
Dim BlankFound As Boolean
Dim x As Long, n As Long, y As Long
Dim firstrow As Long, pasterow As Long, lastrow As Long, PasteCell As String, MyRange As String
'Turns off Screen updating to save memory
Application.ScreenUpdating = False
'Store an initial value for "x" effectively starting the macro at C4 after the +1 in the next step
x = 3
n = 0
y = 0
Set wQuick = ThisWorkbook.Sheets("Quick Reference")
Set wMaster = ThisWorkbook.Sheets("MASTER")
BlankFound = False
'Loop until x equals 600
Do While BlankFound = False
x = x + 1
n = n + 1
If Trim(wQuick.Cells(x, "B").Value) = "" Then Exit Do
'If there is a 1 in the Boolean column then ...
If Trim(wQuick.Cells(x, "C").Value) = "1" Then
'Move the y value so that the template is pasted in the appropriate place
y = y + 1
'Copy the appropriate form from wMaster
firstrow = (n * 9) + 18
lastrow = (n * 9) + 27
Let MyRange = "A" & firstrow & ":" & "K" & lastrow
wMaster.Range(MyRange).Copy
'Select the next place for the form to be pasted on wQuick
pasterow = (y * 9) - 5
Let PasteCell = "F" & "," & pasterow
wQuick.Cells(PasteCell).Paste
End If
Loop
Application.ScreenUpdating = True
End Sub
Please avoid copy-paste in Excel, better use a for-loop like the following:
# keep track of MyRange.Row and MyRange.Column
For Each cell in wMaster.Range(MyRange):
wQuick.Cells(<Starting point>).Offset(<take the cell coordinates, based on MyRange.Row and/or MyRange.Column>).Value = cell.Value
Next
I have a bubble sort that only works with the first element.
This is solved by reevaluating my array elements and placing them accordingly, which happens if I run the whole thing time and time again.
I'd like to add a recursive loop that's set to break when the sort is done.
I tried adding a function, but I'm not solid enough on my syntax to combine it with my sub. What is a basic recursion loop for this code? Function not expressly required, just something that will let me recall my sub.
Private Sub SortEverything_Click()
Dim everything() As Range
Dim check As Range
Dim count As Range
Dim sorting As Range
Dim holder As Range
Dim middleman As Range
Dim firstman As Range
Dim Temp1 As String
Dim Temp2 As String
Dim lr As Long
Dim x As Long
Dim y As Long
Dim z As Long
Dim q As Long
Dim everyrow As Long
Dim everycol As Long
Dim firstrow As Long
Dim firstcol As Long
y = 0
z = 0
q = 0
With ThisWorkbook.Sheets("Names and Vendors")
lr = .Cells(.Rows.count, "B").End(xlUp).Row
'Counts number of RMs to size the "everything" array
For z = 2 To lr
Set count = .Range("B" & z)
If IsEmpty(count) = False Then
count.Select
q = q + 1
End If
Next z
ReDim everything(q - 1) As Range 'Resizes array
'Loops all RM info into array by each distinct range
For x = 2 To lr
Set check = .Range("A" & x & ":H" & x)
'ensures subcomponents are added to range
If IsEmpty(.Range("B" & 1 + x)) = True Then
Do While IsEmpty(.Range("B" & 1 + x)) = True And x < lr
Set check = Union(check, .Range("A" & 1 + x & ":H" & 1 + x))
check.Select
x = x + 1
Loop
End If
Set everything(y) = check
y = y + 1
check.Select
Next x
'This For has been commented out so that it doesn't run more than once
'For y = 0 To q - 1
'sorting allows us to copy/paste into a helper range line-by-line as the program loops
'firstman is the helper range. firstrow and firstcol return the dimensions of the everything(y) so that we can resize things
Set sorting = everything(0)
Set firstman = .Range("B20")
Set firstman = firstman.Resize(sorting.Rows.count, sorting.Columns.count)
firstman.Value = sorting.Value
firstrow = firstman.Rows.count
firstcol = firstman.Columns.count
'Returns the name of the RM listed to compare to the one below it
sorting.Offset(0, 1).Select
ActiveCell.Select
Temp1 = "" & ActiveCell.Value
For x = 1 To q - 1
'Checks whether a selected component has subcomponents and identifies its dimensions
sorting.Select
Set holder = everything(x)
holder.Offset(0, 1).Select
everyrow = Selection.Rows.count
everycol = Selection.Columns.count
'Returns the name of the material being compared to the referenced material in everything(y)
ActiveCell.Select
Temp2 = "" & ActiveCell.Value
If Temp2 > Temp1 Then 'If the RM we're on comes alphabetically after the name of the one we're checking against, then
If everyrow > 1 Then 'Handles if everything(x) has subcomponents
'Resize the other helper range to be the same as the range with subcomponents and paste the values into it
Set middleman = .Range("A1").Offset(0, everything(x).Columns.count)
Set middleman = middleman.Resize(everyrow, everycol)
middleman.Select
middleman.Value = holder.Value
'Resize the range we're pasting into in the master table so it can take the new range, then paste
Set sorting = sorting.Resize(everyrow, everycol)
sorting.Select
sorting.Value = holder.Value
'Resize the holder column to the same size as everything(y).
'Then paste everything(y) into the space BELOW the one we've just shifted upwards
Set holder = holder.Resize(firstrow, firstcol)
Set holder = holder.Offset(everyrow - 1, 0)
holder.Select
holder.Value = firstman.Value
Set sorting = sorting.Offset(everyrow, 0)
Else
Set middleman = .Range("A1").Offset(0, everything(x).Columns.count)
Set middleman = middleman.Resize(firstrow, firstcol)
middleman.Select
middleman.Value = holder.Value
Set sorting = sorting.Resize(everyrow, everycol)
sorting.Select
sorting.Value = holder.Value
Set holder = holder.Resize(firstrow, firstcol)
'Set firstman = firstman.Resize(everyrow, everycol)
holder.Select
holder = firstman.Value
Set sorting = sorting.Offset(1, 0)
End If
End If
Next x
'Next y
'This is where my inexperience shows. The recursion should go here, but I'm not sure how to do so.
'PopulateArray (everything)
End With
End Sub
Public Function PopulateArray(myArray()) As Variant
Dim myArray() As Range
Dim check As Range
Dim count As Range
Dim sorting As Range
Dim holder As Range
Dim middleman As Range
Dim firstman As Range
Dim Temp1 As String
Dim Temp2 As String
Dim lr As Long
Dim x As Long
Dim y As Long
Dim z As Long
Dim q As Long
y = 0
z = 0
q = 0
With ThisWorkbook.Sheets("Names and Vendors")
lr = .Cells(.Rows.count, "B").End(xlUp).Row
'Counts number of RMs to size the "myArray" array
For z = 2 To lr
Set count = .Range("B" & z)
If IsEmpty(count) = False Then
count.Select
q = q + 1
End If
Next z
ReDim myArray(q - 1) As Range 'Resizes array
'Loops all RM info into array by each distinct range
For x = 2 To lr
Set check = .Range("A" & x & ":H" & x)
'ensures subcomponents are added to range
If IsEmpty(.Range("B" & 1 + x)) = True Then
Do While IsEmpty(.Range("B" & 1 + x)) = True And x < lr
Set check = Union(check, .Range("A" & 1 + x & ":H" & 1 + x))
check.Select
x = x + 1
Loop
End If
Set myArray(y) = check
y = y + 1
check.Select
Next x
End With
End Function
Found out what I needed to do. Put the whole thing under a Do loop and then added the following lines to it:
'checking to see if array is completely alphabetized
For Each cell In .Range("B2:B" & lr)
'Returns first check value
If IsEmpty(cell) = False Then
cell.Select
check1 = "" & cell.Value
x = cell.Row
.Range("A14").Value = check1
'Returns next check value
For z = x + 1 To lr
Set checking = .Range("B" & z)
If IsEmpty(checking) = False Then
checking.Select
check2 = "" & .Range("B" & z).Value
.Range("A15").Value = check2
Exit For
End If
Next z
Else
End If
If check2 > check1 Then
Exit For
End If
Next cell
'If the last two values are sorted, then the whole thing is sorted and we can stop the recursion
If check2 < check1 Or check1 = check2 Then
Exit Do
End If
I've been toying with this very simple code and am completely baffled. Below are three different variations I have tried in order to figure out the issue and none have worked.
Original Code:
Sub GetResults()
Set Result = ActiveWorkbook.Worksheets("Results")
Set UTDT = ActiveWorkbook.Worksheets("UTDT")
Set RADAR = ActiveWorkbook.Worksheets("RADAR")
Dim y As Long
Dim i As Long
Dim x As Long
For x = 2 To RADAR.UsedRange.Rows.Count
For i = 2 To UTDT.UsedRange.Rows.Count
For y = 2 To Result.UsedRange.Rows.Count
If UTDT.Cells(i, 1) = RADAR.Cells(x, 1) And UTDT.Cells(i, 25) <> RADAR.Cells(x, 2) Then
Result.Cells(y, 1) = Trim(UTDT.Cells(i, 1))
Result.Cells(y, 2) = UTDT.Cells(i, 2)
Result.Cells(y, 3) = UTDT.Cells(i, 3)
Result.Cells(y, 4) = "Update"
End If
Next y
Next i
Next x
End Sub
I then remove the and portion and added a message box to simplify it:
Sub GetResults()
Set Result = ActiveWorkbook.Worksheets("Results")
Set UTDT = ActiveWorkbook.Worksheets("UTDT")
Set RADAR = ActiveWorkbook.Worksheets("RADAR")
Dim y As Long
Dim i As Long
Dim x As Long
For x = 2 To RADAR.UsedRange.Rows.Count
For i = 2 To UTDT.UsedRange.Rows.Count
For y = 2 To Result.UsedRange.Rows.Count
If UTDT.Cells(i, 1) = RADAR.Cells(x, 1) Then
MsgBox ("It WORKED!")
End If
Next y
Next i
Next x
End Sub
Still skips the IF statement. So i decided ill change it to <> in case its skipping because invisible formatting is causing it to be false.. but still no luck:
Sub GetResults()
Set Result = ActiveWorkbook.Worksheets("Results")
Set UTDT = ActiveWorkbook.Worksheets("UTDT")
Set RADAR = ActiveWorkbook.Worksheets("RADAR")
Dim y As Long
Dim i As Long
Dim x As Long
For x = 2 To RADAR.UsedRange.Rows.Count
For i = 2 To UTDT.UsedRange.Rows.Count
For y = 2 To Result.UsedRange.Rows.Count
If UTDT.Cells(i, 1) <> RADAR.Cells(x, 1) Then
MsgBox ("It WORKED!")
End If
Next y
Next i
Next x
End Sub
I'm having trouble with a Runtime Error 13 "Type mismatch error". I am trying to take multiple lines of code and condense them into one line that is each row placed side by side. The problem is that my inputs are strings and numbers, which is what I believe is causing this problem. How can I fix this?
Sub multRowsTo1Row()
Dim inputRange As Variant
Dim outputRange As Variant
inputRange = Selection
y = UBound(inputRange, 1)
x = UBound(inputRange, 2)
ReDim outputRange(1 To x * y)
For j = 1 To y
For i = 1 To x
outputRange(i + y(j - 1)) = inputRange(j, i)
Next i
Next j
Selection.Offset(0, x).Select
End Sub
Declare your variables Dim x#, y# correctly. That will fix your Mismatch error, but will present you with another error, since y(j - 1) expects an array. Add the multiplication sign so that it is y * (j-1) and you will avoid that error, but you may get an overflow in the event that Selection.Rows.Count > 2, so you might also want to add a check for that.
Sub multRowsTo1Row()
Dim inputRange As Variant
Dim outputRange As Variant
Dim y#, x#
If selection.Rows.Count > 2 Then
MsgBox "Invalid Selection!", vbCritical
Exit Sub
End If
inputRange = Selection
y = UBound(inputRange, 1)
x = UBound(inputRange, 2)
ReDim outputRange(1 To x * y)
For j = 1 To y
For i = 1 To x
outputRange(i + y * (j - 1)) = inputRange(j, i)
Next i
Next j
Selection.Offset(0, x).Select
End Sub
As always, much pain & troubleshooting can be avoided with use of Option Explicit and also dimensioning your variables to a specific Type :)
I was successful thanks to David. Here's my finalized code.
Sub multRowsTo1Row()
'' This takes a multiple line array and places each row side by side
'' Currently places it next to the top row. This can be changed.
Dim inputRange As Variant
Dim outputRange As Variant
Dim x#, y#
inputRange = Selection
y = UBound(inputRange, 1)
x = UBound(inputRange, 2)
ReDim outputRange(1 To x * y)
For j = 1 To y
For i = 1 To x
outputRange(i + x * (j - 1)) = inputRange(j, i)
Next i
Next j
''Change this if you want to output somewhere else. This pastes the output to the right side of the last entry in the first row.
Selection.Offset(0, x).Resize(1, x * y).Select
Selection = outputRange
End Sub