I'm trying to write VBA code to cut/copy paste rows in one worksheet to a new worksheet as long as column H contains any of the values I dictate.
The current code I have works when I only set one value, but I would like the code to execute as long as any of the values I dictate are in the cell. Please advise, thanks.
Sub CutPastebyAM()
Dim sht1 As Worksheet, sht2 As Worksheet
Dim i As Long
Set sht1 = ThisWorkbook.Worksheets("Data")
Set sht2 = ThisWorkbook.Worksheets("Sheet1")
For i = 2 To sht1.Cells(sht1.Rows.Count, "H").End(xlUp).Row
If sht1.Range("H" & i).Value = "Laine Sikula" Or "Kim Gotti" Then
sht1.Range("A" & i).EntireRow.Cut sht2.Range("A" & sht2.Cells(sht2.Rows.Count, "H").End(xlUp).Row + 1)
End If
Next i
End Sub
Almost there:
EDIT - copying to different sheets
Sub CutPastebyAM()
Dim sht1 As Worksheet
Dim i As Long, v, SheetName
Set sht1 = ThisWorkbook.Worksheets("Data")
For i = 2 To sht1.Cells(sht1.Rows.Count, "H").End(xlUp).Row
Select Case sht1.Range("H" & i).Value
Case "Laine Sikula": SheetName = "Sheet1"
Case "Kim Gotti": SheetName = "Sheet2"
Case Else: SheetName = ""
End Select
If Len(SheetName) > 0 Then
With Sheets(SheetName)
sht1.Range("A" & i).EntireRow.Cut _
.Range("A" & .Cells(.Rows.Count, "H").End(xlUp).Row + 1)
End With
End If
Next i
End Sub
Related
I wan't to transfer data within a range from each worksheet of a workbook excluding specific worksheet names based on a value being greater than zero within a range. Based on the value being greater than zero I wan't to transfer corresponding column values in the same row and update the database sheet by putting the values under specific columns from all worksheets apart from specific sheet and populate the list in the database sheet. My code does not seem to be working.
Sub Button4_Click()
Dim sourceRng As Range
Dim cell As Range
Dim i As Long
Dim ws As Worksheet
Dim wsC As Worksheet
Set wsC = Sheets("Database")
For Each wkSht In ThisWorkbook.Worksheets
If ws.Name <> "Database" And ws.Name <> "Combine" And ws.Name <> "CETIN" Then
Set sourceRng = ActiveSheet.Range("AY17:AY30")
i = 1
For Each cell In sourceRng
If cell.Value > 0 Then
cell.Resize(1, 1).Copy Destination:=wsD.Range("A" & i)
i = i + 1
End If
Next cell
End If
Next
End Sub
I believe this should work for you. Your image is hard to read, so you may need to adjust the columns if I read them wrong.
Option Explicit
Sub Button4_Click()
Dim i As Long
Dim wkSht As Worksheet
Dim wsC As Worksheet
Dim rowCount As Integer
Dim nextEmptyRow As Integer
Set wsC = ThisWorkbook.Worksheets("Database")
For Each wkSht In ThisWorkbook.Worksheets
nextEmptyRow = wsC.Cells(Rows.Count, "A").End(xlUp).Row + 1
If wkSht.Name <> "Database" And wkSht.Name <> "Combine" And wkSht.Name <> "CETIN" Then
For i = 17 To 30
If wkSht.Range("AY" & i).Value > 0 Then
wkSht.Range("AY" & i).Copy Destination:=wsC.Range("A" & nextEmptyRow)
wkSht.Range("K" & i).Copy Destination:=wsC.Range("B" & nextEmptyRow)
wkSht.Range("R" & i).Copy Destination:=wsC.Range("C" & nextEmptyRow)
wkSht.Range("T" & i).Copy Destination:=wsC.Range("D" & nextEmptyRow)
End If
Next i
End If
Next wkSht
End Sub
You can also replace wkSht.Range("AY" & i).Copy Destination:=wsC.Range("A" & nextEmptyRow) with wsC.Range("A" & nextEmptyRow).value = wkSht.Range("AY" & i).value for those 4 lines if you only want to preserve the value and not formatting.
First of all thanks for your help.
I've been trying to get a dynamic list that copies values from on excel to another depending on an "IF" condition, which has worked quite fine. But I can only do it for 1 condition instead of a Range of conditions.
In excel I would usually use the COUNTIF function to see if you can find a range of values inside another range, but i am quite new to VBA and I wouldn't know how how to express this in a loop for a Range.
Example below of what has worked with one condition:
As you can see I am using "Investor" as my condition, but I need it to be for a range of values.
Thanks for your help!
LastRows = Worksheets("Data").Cells(Rows.Count, 1).End(xlUp).Row + 1
For i = 2 To LastRows
If Worksheets("Data").Range("F" & i).Value = "Investor" Then
'Instead of "Investor" I want to do something that take a list of values. Eg : If If Worksheets("Data").Range("F" & i).Value = "Range("A1:A"&LastRows) Then
Worksheets("Data").Range("A" & i).Copy
Worksheets("Email Format").Activate
LastRowEmail = Worksheets("Email Format").Cells(Rows.Count, 1).End(xlUp).Row + 1
Worksheets("Email Format").Range("A" & LastRowEmail).Select
ActiveSheet.Paste
End If
Application.Match Vs WorksheetFunction.Match
You can use one of the following Match solutions.
Option Explicit
Sub MultiCriteria1()
Dim wb As Workbook: Set wb = ThisWorkbook
Dim wsD As Worksheet: Set wsD = wb.Worksheets("Data")
Dim wsE As Worksheet: Set wsE = wb.Worksheets("Email Format")
Dim LastRowD As Long: LastRowD = wsD.Cells(wsD.Rows.Count, 1).End(xlUp).Row
Dim CurrentE As Long: CurrentE = wsE.Cells(wsE.Rows.Count, 1).End(xlUp).Row
Dim i As Long
For i = 2 To LastRowD
If Not IsError(Application.Match(wsD.Range("F" & i).Value, _
wsD.Range("A1:A" & LastRowD), 0)) Then
CurrentE = CurrentE + 1
wsE.Range("A" & CurrentE).Value = wsD.Range("A" & i).Value
End If
Next i
End Sub
Sub MultiCriteria2()
Dim wb As Workbook: Set wb = ThisWorkbook
Dim wsD As Worksheet: Set wsD = wb.Worksheets("Data")
Dim wsE As Worksheet: Set wsE = wb.Worksheets("Email Format")
Dim LastRowD As Long: LastRowD = wsD.Cells(wsD.Rows.Count, 1).End(xlUp).Row
Dim CurrentE As Long: CurrentE = wsE.Cells(wsE.Rows.Count, 1).End(xlUp).Row
Dim CurrVal As Long
Dim i As Long
For i = 2 To LastRowD
On Error Resume Next
CurrVal = WorksheetFunction.Match(wsD.Range("F" & i).Value, _
wsD.Range("A1:A" & LastRowD), 0)
If Err.Number = 0 Then
CurrentE = CurrentE + 1
wsE.Range("A" & CurrentE).Value = wsD.Range("A" & i).Value
End If
On Error GoTo 0
Next i
End Sub
This is just an example but should steer you in right direction.
Dim rngYourRange as Range
Set rngYourRange = Range("A1:C10")
Dim rngEachRange as Range
For each rngEachRange in rngYourRange 'or rngYourRange.Rows or rngYourRange.Columns
if rngEachRange.value = 1 then 'or whatever
'do what you need
end if
next rngEachRange
I've created several macro buttons on worksheet 5, this works if I'm on worksheet 1 but when I try to click the button for this macro on worksheet 5 it doesn't work. What do I need to add to make it select worksheet 1 if I'm on another worksheet in the same workbook?
Sub Delete_External ()
'
' Delete_External Macro
Dim LastRow As Long
Dim i As Long
LastRow = Range("K1000").End(xlUp).Row
For i = LastRow To 1 Step -1
If Range("K" & i) = "External" Then
Range("K" & i).EntireRow.Delete
End If
Next
End Sub
Qualify your objects with a worksheet.
Sub Delete_External ()
'
' Delete_External Macro
Dim ws as Worksheet: Set ws = ThisWorkbook.Sheets("Sheet1")
Dim LastRow As Long
Dim i As Long
LastRow = ws.Range("K1000").End(xlUp).Row
For i = LastRow To 1 Step -1
If ws.Range("K" & i) = "External" Then
ws.Range("K" & i).EntireRow.Delete
End If
Next
End Sub
I would avoid deleting rows inside your loop as this can become time consuming depending on the data set and amount of criteria matches. Consider this alternative that loops through your range and creates a collection (Union) of cells that match your criteria. Once the loop is complete, delete the Union all at once.
This has also been updated to a more common last row finder methodology and removes the backwards loop since this method does not require it!
Sub Delete_External()
'
' Delete_External Macro
Dim ws As Worksheet: Set ws = ThisWorkbook.Sheets("Sheet1")
Dim LR As Long, i As Long
Dim DeleteMe As Range
LR = ws.Range("K" & ws.Rows.Count).End(xlUp).Row
For i = 2 To LR
If ws.Range("K" & i) = "External" Then
If Not DeleteMe Is Nothing Then
Set DeleteMe = Union(DeleteMe, ws.Range("K" & i))
Else
Set DeleteMe = ws.Range("K" & i)
End If
End If
Next i
If Not DeleteMe Is Nothing Then
DeleteMe.EntireRow.Delete
End If
End Sub
I am trying to create code (Loop) so that when a task is allocated to a team member (in a cell in column H) the code searches the cell value with the existing sheet names and if there is a match, the sheet then makes the task member sheet active sheet, finds the last available line and adds the allocated tasks to the sheet. The code should run for all filled cells in the column.
However, the code i have currently written bugs out. I am finding it hard to define the worksheetname (Cell value) etc.
Sub TaskAllocation()
Dim cell As Range, Lastrow1 As Double, i As Integer
Dim SubTaskWs As Worksheet, Ws As Worksheet, Lastrow2 As Double
Set SubTaskWs = ActiveWorkbook.Worksheets("Sub tasks")
Set Ws = ActiveWorkbook.Sheets(WsName)
i = o
Lastrow1 = SubTaskWs.Range("H" & Rows.Count).End(xlUp).Row
Lastrow2 = Ws.Range("A" & Rows.Count).End(xlUp).Row
For Each cell In SubTaskWs.Range("H4:H" & Lastrow1)
For Each Ws In Sheets
If cell.value = Ws.Name Then
Ws.Range("A" + (Lastrow2 + (i))).EntireRow.Insert
Call copyFormattingAbove(Ws, "A" & Lastrow2)
Ws.Range(("A" & Lastrow2) + (i)).value = cell.Offset(, -6)
Ws.Range(("B" & Lastrow2) + (i)).value = cell.Offset(, -5)
i = i + 1
End If
Next Ws
Next cell
End Sub
I did change a bit your code to make it more readable.
Some tips for the future:
Use the Option Explicit on the top of your moduel to fource the declaration of all your variables.
Always try to declare your variables close to where they are used.
Never declare a integervariable, use Long instead. Don't use Double for rows either, Double and Single are for floating numbers.
Here is the code:
Option Explicit
Sub TaskAllocation()
Dim cell As Range
Dim SubTaskWs As Worksheet
Set SubTaskWs = ActiveWorkbook.Worksheets("Sub tasks")
Dim Lastrow1 As Long
Lastrow1 = SubTaskWs.Range("H" & Rows.Count).End(xlUp).Row
Dim ws As Worksheet
Dim cell As Range
Dim Lastrow2 As Long, i As Long
i = 0
Dim Tasks As Object
FillTasks Tasks
For Each cell In SubTaskWs.Range("H4:H" & Lastrow1) 'change this range and loop through the column with the tasks
If Tasks.Exists(cell) Then GoTo AlreadyDone
For Each ws In Sheets
If SubTaskWs.Cells(cell.Row, "H") = ws.Name Then
Lastrow2 = ws.Range("A" & Rows.Count).End(xlUp).Row + 1
copyFormattingAbove ws, "A" & Lastrow2
ws.Range("A" & Lastrow2).Value = SubTaskWs.Cells(cell.Row, 2)
ws.Range("B" & Lastrow2).Value = SubTaskWs.Cells(cell.Row, 3)
End If
Next ws
AlreadyDone:
Next cell
End Sub
Function FillTasks(Tasks As Object)
Set Tasks = CreateObject("Scripting.Dictionary")
Dim ws As Worksheet
For Each ws In ThisWorkbook.Worksheets 'loop through sheets
If Not ws.Name = "Sub tasks" Then
'code to find the right columnd and loop through the existing tasks
'there is no need for an item on this case, you only need to know if it exists
If Not Tasks.Exists(cell) Then Tasks.Add cell, 1
End If
Next ws
End Function
I am currently trying to make a macro to pull all of the data from a specific row on my sales quote template workbook and then make it paste into the next available row on my quote logger workbook but im really struggling to find the right code to make it work. ive searched around but found nothing concrete that I could use.
what I have so far is below.
Option Explicit
Sub Test()
Dim sht1 As Worksheet, sht2 As Worksheet
Dim i As Long
Set sht1 = ThisWorkbook.Worksheets("Sheet1")
Set sht2 = "..............RAYOTEC LOGGER.xlsm"
For i = 2 To sht1.Cells(sht1.Rows.Count, "M").End(xlUp).Row
If sht1.Range("M" & i).Value = "No" Then
sht1.Range("A" & i).EntireRow.Cut sht2.Range("A" & sht2.Cells(sht2.Rows.Count, "M").End(xlUp).Row + 1)
End If
Next i
End Sub
Thanks in advance for any help
Change the part of your code before FOR loop with this,
Dim sht1 As Worksheet
Dim sht2 As Worksheet
Dim wb As Workbook
Dim i As Long
Set sht1 = ThisWorkbook.Worksheets("Sheet1")
Set wb = Application.Workbooks.Open("..............RAYOTEC LOGGER.xlsm")
Set sht2 = wb.Sheets("Sheet1")
Also you can use the below for the rest of the code as it just takes the values easily and deletes the row data that you do not need.
Dim sht1 As Worksheet
Dim sht2 As Worksheet
Dim i, n As Long
Dim iMx, nMx As Long
iMx = sht1.Cells(sht1.Rows.Count, "M").End(xlUp).Row
For i = 2 To iMx
nMx = sht2.Cells(sht2.Rows.Count, "A").End(xlUp).Row
If sht1.Range("M" & i).Value = "No" Then
sht2.Range("A" & nMx + 1).EntireRow.Value = sht1.Range("A" & i).EntireRow.Value
sht1.Range("A" & i).EntireRow.Delete Shift:=xlUp
i = i - 1
End If
Next i