I have 150+ categories and I enter data on excel
Now I need your help.
If I enter any category on Column A excel should check if there is a worksheet naming that category. If yes then it should copy the entire row to the next empty row of that worksheet and if it doesn’t find that worksheet it should create a worksheet naming that category and then copy the entire row to the next empty row of that newly created worksheets. Is it possible?
Thanks a million, in advance for your help.
I use this code to copy entire row to another worksheet is there any way to update it so that it meets my requirements?
Sub CopyRowBasedOnCellValue()
Dim xRg As Range
Dim xCell As Range
Dim A As Long
Dim B As Long
Dim C As Long
A = Worksheets("Sheet1").UsedRange.Rows.Count
B = Worksheets("Sheet2").UsedRange.Rows.Count
If B = 1 Then
If Application.WorksheetFunction.CountA(Worksheets("Sheet2").UsedRange) = 0 Then B = 0
End If
Set xRg = Worksheets("Sheet1").Range("C1:C" & A)
On Error Resume Next
Application.ScreenUpdating = False
For C = 1 To xRg.Count
If CStr(xRg(C).Value) = "Done" Then
xRg(C).EntireRow.Copy Destination:=Worksheets("Sheet2").Range("A" & B + 1)
B = B + 1
End If
Next
Application.ScreenUpdating = True
End Sub
Related
I am starting out with a table containing a name which corresponds to a job code and the start date of said job. See below:
The desired outcome of this is to almost flip it (it is becoming part of a bigger macro, must use VBA for this)
I need dates along the column headings, and the list of unique names. In the column will appear the job for that date. See below for an example:
I have been able to get the code to select all of the rows containing a persons name, however I can't workout how to one by one go through each of the selected rows, copy the job code and paste it to the new table under the correct corresponding date.
Since some jobs have multiple people this code uses InStr() to find occurances of the unqiue names
Sub NewTable()
Dim Rng As Range
Dim Cell As Object
Dim Found As Range
Dim Ws As Worksheet
Set Ws = Worksheets("Sheet1")
Set Rng = Ws.Range("D:D")
searchString = "Emily"
For Each Cell In Rng
If InStr(Cell, searchString) > 0 Then
If Not Found Is Nothing Then
Set Found = Union(myUnion, Cell.EntireRow)
Else
Set Found = Cell.EntireRow
End If
End If
Next
If Found Is Nothing Then
MsgBox "The text was not found in the selection"
Else
Found.Select
End If
End Sub
Any help would be appreciated
Try this out:
Sub Tester()
Dim rw As Range, wsData As Worksheet, wsPivot As Worksheet, arr, e, r, c
Set wsData = ThisWorkbook.Worksheets("Input") 'sheet with original data
Set wsPivot = ThisWorkbook.Worksheets("Pivot") 'sheet for the final table
'loop over each row in the input table
For Each rw In wsData.Range("B6:E" & wsData.Cells(Rows.Count, "B").End(xlUp).Row).Rows
If Application.CountA(rw) = 3 Then 'row has data?
'try to match the date: add as new date if no match
c = Application.Match(CLng(rw.Cells(3).Value), wsPivot.Rows(1), 0)
If IsError(c) Then
c = wsPivot.Cells(1, Columns.Count).End(xlToLeft).Column + 1
If c < 4 Then c = 4 'dates start in D1
wsPivot.Cells(1, c).Value = rw.Cells(3).Value 'add the date
End If
arr = Split(rw.Cells(2).Value, ",") 'get array of all names
'check row for each name: add as new name if no match
For Each e In arr
'look for the name in Col B
r = Application.Match(Trim(e), wsPivot.Columns("B"), 0)
'if name not found, then add it in the next empty cell
If IsError(r) Then
r = wsPivot.Cells(Rows.Count, "B").End(xlUp).Row + 1
If r < 4 Then r = 4 'names begin in B4
wsPivot.Cells(r, "B").Value = e
End If
wsPivot.Cells(r, c).Value = rw.Cells(1).Value 'add the Job Code
Next e
End If
Next rw
End Sub
I have a worksheet that I've made to track progress on projects. I currently have an active x button that when clicked it moves a row from the active worksheet (Project Tracker) to another worksheet (Released). The value that would trigger this action would be in column J (Released). This works perfectly.
I would like to have multiple worksheets that have the same names as the project names which are based on different companies that would be selected from a drop-down list (to stop typos). I need help on code to move the cut rows to these certain sheets.
Current code:
enter code here
Sub CommandButton1_Click()
Dim xRg As Range
Dim xCell As Range
Dim I As Long
Dim J As Long
Dim K As Long
DIM T AS
I = Worksheets("PROJECT TRACKER").UsedRange.Rows.Count
J = Worksheets("RELEASED").UsedRange.Rows.Count
If J = 1 Then
If Application.WorksheetFunction.CountA(Worksheets("RELEASED").UsedRange) = 0 Then J = 0
End If
Set xRg = Worksheets("PROJECT TRACKER").Range("L1:L" & I)
On Error Resume Next
Application.ScreenUpdating = False
For K = 1 To xRg.Count
If CStr(xRg(K).Value) = "RELEASED" Then
xRg(K).EntireRow.Cut Destination:=Worksheets("RELEASED").Range("A" & J + 1)
xRg(K).EntireRow.Delete
If CStr(xRg(K).Value) = "RELEASED" Then
K = K - 1
End If
J = J + 1
End If
Next
Application.ScreenUpdating = True
End Sub
his is cross-posted
https://www.excelguru.ca/forums/showthread.php?10476-Cut-and-Paste-a-row-in-one-sheet-to-another-based-on-a-cell-value
I have Sheet 1 (Column A ) value and Sheet 2 (Column A). I want to compare sheet 1 column A with sheet 2 Column A. If Sheet 1 (Column A) is found in the Sheet 2 then Delete the entire row in the Sheet 1. go to next one.
I have been stuck on this. Below is my Code. Its not working. Its keep getting wrong cell values
Sub Compare()
Dim i As Long
Dim j As Long
Dim lastRow_Task As Long
Dim lastRow_Compare As Long
Dim lastRow As Long
'Sheet 1
Dim Task As Worksheet
'Sheet 2
Dim Compare As Worksheet
Set Task = Excel.Worksheets("TaskDetails")
Set Compare = Excel.Worksheets("Compare")
Application.ScreenUpdating = False
lastRow_Task = Log.Cells(Rows.count, "A").End(xlUp).Row
lastRow_Compare = Compare.Cells(Rows.count, "A").End(xlUp).Row
For i = 2 To lastRow_Task
For j = 2 To lastRow_Compare
If Task.Cells(i, "A").Value = Compare.Cells(j, "A").Value Then
Compare.Cells(j, "A").ClearContents
End If
Next j
Next i
Using Match() is fast and will avoid the nested loop.
Also - when deleting rows it's best to work from the bottom to the top so the deleted rows don't interfere with your loop counter.
Sub Compare()
Dim i As Long
Dim lastRow_Task As Long
Dim Task As Worksheet 'Sheet 1
Dim Compare As Worksheet 'Sheet 2
Set Task = ActiveWorkbook.Worksheets("TaskDetails")
Set Compare = ActiveWorkbook.Worksheets("Compare")
Application.ScreenUpdating = False
lastRow_Task = Task.Cells(Task.Rows.Count, "A").End(xlUp).Row
For i = lastRow_Task To 2 Step -1
If Not IsError(Application.Match(Task.Cells(i, 1).Value, Compare.Columns(1), 0)) Then
Task.Rows(i).Delete
End If
Next i
Application.ScreenUpdating = True
End Sub
I'm very new to VBA. Trying to copy specific columns within a row if Column O has the text "Open".
Have tried the code below and it works except it copies the entire row and I only want to copy the row but limited to columns E to Q. How do i insert the column range requirement?
Sub Button2_Click()
Dim c As Range
Dim j As Integer
Dim Source As Worksheet
Dim Target As Worksheet
' Change worksheet designations as needed
Set Source = ActiveWorkbook.Worksheets("SheetA")
Set Target = ActiveWorkbook.Worksheets("SheetB")
j = 3 ' Start copying to row 3 in target sheet
For Each c In Source.Range("O13:O1500") ' Do 1500 rows
If c = "Open" Then
Source.Rows(c.Row).Copy Target.Rows(j)
j = j + 1
End If
Next c
End Sub
try
Source.Rows(c.Row).Columns("E:Q").Copy Target.Rows(j)
You should be able to use Union to gather the qualifying ranges and paste in one go which will be more efficient
Public Sub Button2_Click()
Dim c As Range, unionRng As Range
Dim Source As Worksheet, Target As Worksheet
Set Source = ActiveWorkbook.Worksheets("SheetA")
Set Target = ActiveWorkbook.Worksheets("SheetB")
For Each c In Source.Range("O13:O1500")
If c = "Open" Then
If Not unionRng Is Nothing Then
Set unionRng = Union(unionRng, Source.Rows(c.Row).Columns("E:Q"))
Else
Set unionRng = Source.Rows(c.Row).Columns("E:Q")
End If
End If
Next c
If Not unionRng Is Nothing Then unionRng.Copy Target.Range("A3")
End Sub
Intersect(Source.Rows(c.Row), Source.Range("E:Q")).Copy Target.Rows(j)
or
Source.Range("E:Q").Rows(c.Row).Copy Target.Rows(j)
While copying, you are trying to copy a specific range. So instead of using :
Source.Rows(c.Row).Copy Target.Rows(j)
Use
Source.Range("E*row*:Q*row*").Copy Target.Rows(j)
Where *row* is the row number. So you can copy Range from columns E to Q while keeping the row number fixed.
So the final code is
Sub Button2_Click()
Dim c As Range
Dim r As String 'Store the range here
Dim j As Integer
Dim Source As Worksheet
Dim Target As Worksheet
' Change worksheet designations as needed
Set Source = ActiveWorkbook.Worksheets("SheetA")
Set Target = ActiveWorkbook.Worksheets("SheetB")
j = 3 ' Start copying to row 3 in target sheet
For Each c In Source.Range("O10:O15") ' Do 1500 rows
If c = "Open" Then
r = "E" & c.Row & ":" & "Q" & c.Row 'Creating the range
Source.Range(r).Copy Target.Rows(j)
j = j + 1
End If
Next c
End Sub
Hope this helps !
I have a list of true and false values on sheet 3 column A and a list of codes on sheet 2 Column A. If the value on sheet 3 A5 is = True then I want the value on sheet 2 A5 should be colored red. And If the value on sheet 3 A6 is = True then I want the value on sheet 2 A6 should be colored red. And this should move down along Column A on sheet 2 and sheet 3 until data runs out. So far i have got it to work for the first cell in column A but can not get the For Each loop to work. Any Help would be greatly appreciated.
Sub compare_cols()
Dim myRng As Range
Dim lastCell As Long
'Get the last row
Dim lastRow As Integer
lastRow = ActiveSheet.UsedRange.Rows.Count
'Debug.Print "Last Row is " & lastRow
Dim c As Range
Dim d As Range
Set c = Worksheets("Sheet3").Range("A5:25")
Set d = Worksheets("Sheet2").Range("A5:25")
Application.ScreenUpdating = False
For Each cell In c
For Each cell In d
If c.Value = True Then
d.Interior.Color = vbRed
End If
Next
Next
Application.ScreenUpdating = True
End Sub
A more efficient solution wouldn't necessarily next 2 loops within each other. Instead, loop through the range that you'd like to check, and reference the cells Address property to identify new cells to highlight.
Check the code below and let me know if you understand it
Sub ColorOtherSheet()
Dim wsCheck As Worksheet
Dim wsColor As Worksheet
Dim rngLoop As Range
Dim rngCell As Range
Set wsCheck = Worksheets("Sheet3")
Set wsColor = Worksheets("Sheet2")
Set rngLoop = Intersect(wsCheck.UsedRange, wsCheck.Columns(1))
For Each rngCell In rngLoop
If rngCell.Value = True Then
wsColor.Range(rngCell.Address).Interior.Color = vbRed
End If
Next rngCell
End Sub