I have a datatable with string values, which I want to search for a specific value which I select from a dropdown menu. All matching values should be copied to another worksheet.
My code doesn't work. I dug through lots of stuff, but I am not able to figure out the problem.
Dim datasheet As Worksheet 'data copied from
Dim reportsheet As Worksheet 'data copied to
Dim abhaengigkeit As String
Dim finalrow As Integer
Dim i As Integer 'row counter
'sets vars
Set datasheet = Tabelle1
Set reportsheet = Tabelle44
abhaengigkeit = datasheet.Range("L3").Value
'goto datasheet and search and copy
datasheet.Select
finalrow = Cells(Rows.Count, 15).End(xlUp).Row
'loop to find records
For i = 2 To finalrow
If Cells(i, 15) = abhaengigkeit Then
''Copy Soll''
Range(Cells(i, 16), Cells(i, 23)).Copy 'copy column 1 to 10
reportsheet.Select 'goto reportsheet (Aenderungsfortpflanzung)
Range("A150").End(xlUp).Offset(1, 0).PasteSpecial xlPasteAll 'paste
under last entry
datasheet.Select
End If
Next i
My datasheet (Tabelle1) is where the dropdown and the datatable is. The reportsheet is my destination sheet to copy the matching results.
Cell L3 is the Dropdown menu, my datatable loop should run through column P and copy all values which are stated in the following 8 columns.
This works
Option Explicit
Public Sub test()
Dim datasheet As Worksheet
Dim reportsheet As Worksheet
Dim abhaengigkeit As String
Dim finalrow As Long
Dim i As Long
Set datasheet = ThisWorkbook.Worksheets("Tabelle1") '<== I have set this up as sheet names not code names
Set reportsheet = ThisWorkbook.Worksheets("Tabelle44")
abhaengigkeit = datasheet.Range("L3").Value
With datasheet
finalrow = .Cells(.Rows.Count, 15).End(xlUp).Row
Dim unionRng As Range
For i = 2 To finalrow
If Cells(i, 15) = abhaengigkeit Then '<column 0
If Not unionRng Is Nothing Then
Set unionRng = Union(unionRng, .Range(.Cells(i, 16), .Cells(i, 23))) ' 'P to W
Else
Set unionRng = .Range(.Cells(i, 16), .Cells(i, 23))
End If
End If
Next i
End With
If Not unionRng Is Nothing Then
If IsEmpty(reportsheet.Range("A150").End(xlUp)) And reportsheet.Range("A150").End(xlUp).Row = 1 Then
unionRng.Copy reportsheet.Range("A1")
Else
unionRng.Copy reportsheet.Range("A150").End(xlUp).Offset(1, 0)
End If
End If
End Sub
Related
So, I am using this macro to search by id(serial number) and then the delete the row elements for that particular row.
The code for deleting the row is:
Sub DeleteMe()
'declare the variables
Dim ID As Range, c As Range, orange As Range
Dim wb As Workbook
Set wb = ThisWorkbook
Set Fws = wb.Sheets("Data")
Set Bws = wb.Sheets("Bookings")
Dim lastrow As Long
'set the object variable
Set ID = Bws.Range("B3")
'stop screen flicker
Application.ScreenUpdating = False
lastrow = Fws.Range("A" & Rows.Count).End(xlUp).Row
Set orange = Fws.Range("A2:A" & lastrow)
'find the value in the range
For Each c In orange
If c.Value = ID.Value Then
'delete the row
c.Cells(1, 2).Clear
c.Cells(1, 3).Clear
c.Cells(1, 4).Clear
c.Cells(1, 5).Clear
c.Cells(1, 6).Clear
c.Cells(1, 7).Clear
c.Cells(1, 8).Clear
c.Cells(1, 9).Clear
c.Cells(1, 10).Clear
c.Cells(1, 11).Clear
c.Cells(1, 12).Clear
c.Cells(1, 13).Clear
c.Clear
End If
Next c
Sheet2.Select
End Sub
I am not deleting the entire row because There are values in further columns which I don't want to touch
After the code is run, my database looks like this:
What I want is to shift all the remaining rows up to fill the empty row. I also want the serial numbers to change accordingly. So in this case 7 will become 6 and 8 will become 7.
Thanks in advance!
Please try this code. It should do what you want.
Sub DeleteMe()
' 018
'declare the variables
Dim Wb As Workbook
Dim Fws As Worksheet, Bws As Worksheet
Dim DelRng As Range
Dim Id As String
Dim Rl As Long ' last row
Dim R As Long ' row counter
'set the object variables
Set Wb = ThisWorkbook
Set Fws = Wb.Sheets("Data")
Set Bws = Wb.Sheets("Bookings")
'stop screen flicker
Application.ScreenUpdating = False
Set Id = Bws.Range("B3")
With Fws
' loop through all cells from bottom to top
' because row numbers will change as you delete cells
For R = .Range("A" & .Rows.Count).End(xlUp).Row To 2 Step -1
'find the value in each row
If .Cells(R, "A").Value = Id.Value Then
Set DelRng = .Range(.Cells(R, 1), .Cells(R, 13))
DelRng.Delete Shift:=xlUp
End If
Next R
Rl = .Cells(.Rows.Count, "A").End(xlUp).Row
For R = 2 To Rl
.Cells(R, "A").Value = R - 1
Next R
End With
End Sub
Try This .. Looping upward helps to ensure all rows are covered. Because if we loop downward once we delete a row then the next row number becomes i -1
Sub DeleteMe()
'declare the variables
Dim Fws As Worksheet, Bws As Worksheet
Dim ID As Range
Dim wb As Workbook
Set wb = ThisWorkbook
Set Fws = wb.Sheets("Data")
Set Bws = wb.Sheets("Bookings")
Dim lastrow As Long
'set the object variable
Set ID = Bws.Range("B3")
'stop screen flicker
Application.ScreenUpdating = False
lastrow = Fws.Range("A" & Rows.Count).End(xlUp).Row
'find the value in the range
Fws.Select
For i = lastrow To 2 Step -1
If Fws.Cells(i, 1) = ID.Value Then
'delete the row
Fws.Range(Cells(i, 1), Cells(i, 13)).Delete Shift:=xlUp
End If
Next
With Range("A2:A" & Range("A" & Rows.Count).End(xlUp).Row)
.Formula = "=ROW() - 1"
.Value = .Value
End With
End Sub
I'm trying to compare sheet1 "A" column values to sheet2 "E:E" column values and copy/paste the whole line of every match to sheet3. Please help me to complete this task. I'm very new to VBA.
Thank you very much in advance!
Sub DelDups_TwoLists()
Dim iListCount As Integer
Dim iCtr As Integer
' Turn off screen updating to speed up macro.
Application.ScreenUpdating = False
' Get count of records to search through (list that will be deleted).
iListCount = Sheets("sheet1").Cells(Rows.Count, "A").End(xlUp).Row
' Loop through the "master" list.
For Each x In Sheets("Sheet2").Range("E:E" & Sheets("Sheet1").Cells(Rows.Count, "A").End(xlUp).Row)
' Loop through all records in the second list.
For iCtr = iListCount To 1 Step -1
' Do comparison of next record.
' To specify a different column, change 1 to the column number.
If x.Value = Sheets("Sheet1").Cells(iCtr, 1).Value Then
' If match is true then delete row.
Sheets("Sheet1").Cells(iCtr, 1).EntireRow.Copy
Sheets("Sheet3").Select.Paste
End If
Next iCtr
Next
Application.ScreenUpdating = True
MsgBox "Done!"
End Sub
Sub DelDupsTwoLists()
Dim lastRowWs1 As Long, lastRowWs2 As Long
Dim ws1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet
Set ws1 = Worksheets(1)
Set ws2 = Worksheets(2)
Set ws3 = Worksheets(3)
lastRowWs1 = LastRow(ws1.Name, 1)
lastRowWs2 = LastRow(ws2.Name, 5) 'E = 5
Dim myCell1 As Range, myCell2 As Range
Dim ws1Range As Range, ws2Range As Range
Set ws1Range = ws1.Range(ws1.Cells(1, "A"), ws1.Cells(lastRowWs1, 1))
Set ws2Range = ws2.Range(ws2.Cells(1, "E"), ws2.Cells(lastRowWs2, 1))
Dim rangeToDelete As Range
For Each myCell1 In ws1Range
For Each myCell2 In ws2Range
If myCell1.Value = myCell2.Value Then
Dim lastRowWs3: lastRowWs3 = LastRow(ws3.Name, 1) + 1
myCell2.EntireRow.Copy Destination:=ws3.Cells(lastRowWs3, 1)
If Not rangeToDelete Is Nothing Then
Set rangeToDelete = Union(rangeToDelete, myCell2.EntireRow)
Else
Set rangeToDelete = myCell2.EntireRow
End If
End If
Next
Next
If Not rangeToDelete Is Nothing Then
Debug.Print "Deleting rangeToDelete - "; rangeToDelete.Address
rangeToDelete.Delete
End If
Debug.Print "Done!"
End Sub
Public Function LastRow(wsName As String, Optional columnToCheck As Long = 1) As Long
Dim ws As Worksheet
Set ws = Worksheets(wsName)
LastRow = ws.Cells(ws.Rows.Count, columnToCheck).End(xlUp).Row
End Function
Pretty much I rewrote the whole code from scratch. It pretty much uses the initial n2 complexity, but is rather faster than that, because the deletion of the rows in WorkSheet(2) is done in a single last step rangeToDelete.Delete, which saves a lot of time.
Pretty much, the code defines 2 ranges with which is works - ws1Range and ws2Range, using the LastRow function. Once it defines them, it starts looping through them and comparing them. Hence the n2 complexity. In case of equal values, the row is copied and the cell is added to the rangeToDelete.
Note - it will probably not work as "out of the box solution", but try to debug further with F8 and see what happens.
Additionally:
Using Integer is not a great idea in VBA.
"_" in the Sub name is used for Events in VBA, thus it is not a great idea to use it. (although it works)
How to avoid using Select in Excel VBA
Give this a try (see comments in code for more details):
Sub DelDups_TwoLists()
' Turn off screen updating to speed up macro.
Application.ScreenUpdating = False
With ActiveWorkbook
Dim wsSrc As Worksheet: Set wsSrc = .Sheets("Sheet1") 'declare and set the source worksheet
Dim wsDst As Worksheet: Set wsDst = .Sheets("Sheet3") 'declare and set the destination worksheet
Dim R1 As Long, R2 As Long, C As Long, lRow As Long, lCol As Long 'declare variables to use
With wsSrc
lCol = .Cells(1, Columns.Count).End(xlToLeft).Column 'get the last column value in the source sheet, at row 1, will reuse this laster
Dim arrData_1 As Variant: arrData_1 = .Range(.Cells(1, 1), .Cells(.Cells(Rows.Count, 1).End(xlUp).Row, 1)) 'declare and allocate the source data to an array
End With
With .Sheets("Sheet2")
Dim arrData_2 As Variant: arrData_2 = .Range("E1:E" & .Cells(Rows.Count, 1).End(xlUp).Row) 'declare and allocate the compare data to an array
End With
End With
With wsDst
For R1 = LBound(arrData_1) To UBound(arrData_1) 'for each row in the source data
For R2 = LBound(arrData_2) To UBound(arrData_2) 'for each row in the compare data
If arrData_1(R1, 2) = arrData_2(R2, 1) Then 'if there is a match
lRow = .Cells(Rows.Count, 1).End(xlUp).Row + 1 'get the last row in the destination sheet
.Range(.Cells(lRow, 1), .Cells(lRow, lCol)).Value = _
wsSrc.Range(wsSrc.Cells(R1, 1), wsSrc.Cells(R1, lCol)).Value 'allocate the matching values
Exit For 'exit early here if there is a match, go to next row to check
End If
Next R2
Next R1
End With
Application.ScreenUpdating = True
MsgBox "Done!"
End Sub
I have the following code which I am using to loop through a worksheet. Each row needs to be copied a certain number of times and the new rows pasted at the bottom, after the last row that currently has any text. The number of rows to copy for each present row is in the cell for column BU of that row.
Hence, in order to do this, I have created the following loop to move through each row and use the cell value in column BU to copy cells in columns A through BT, then paste after the last active visible row.
However, it's not working well.
Any thought?
Sub Transfer()
Application.ScreenUpdating = False
Dim lastrow As Long, lngRows
lastrow = sht.Cells(sht.Rows.Count, 1).End(xlUp).Row + 1
Dim wsSource As Worksheet
Dim wsDest As Worksheet
Dim rowCount As Long
Set wsSource = Worksheets("Forecasted Movement")
With wsSource
rowCount = .Cells(.Rows.Count, "A").End(xlUp).Row ' <-- modifed this line
On Error Resume Next
For i = 2 To rowCount
If .Cells(i, "BU").Value > 0 Then
lngRows = .Cells(i, "BU").Value
Range(Cells(i, 1), Cells(i, 72)).specialcells(xlCellTypeVisible).Copy
wsSource.Cells(lastrow, 1).Resize(lngRows).PasteSpecial Paste:=xlPasteValues
End If
Next i
End With
Application.ScreenUpdating = True
End Sub
If this is all in the same worksheet ( as the code suggests) the your lastrow is your problem. You need to recalculate it everytime you paste a new row.
Sub Transfer()
Application.ScreenUpdating = False
Dim lastrow As Long, lngRows
Dim wsSource As Worksheet
Dim wsDest As Worksheet
Dim rowCount As Long
Set wsSource = Worksheets("Forecasted Movement")
With wsSource
rowCount = .Cells(.Rows.Count, "A").End(xlUp).Row ' <-- modifed this line
On Error Resume Next
For i = 2 To rowCount
If .Cells(i, "BU").Value > 0 Then
lngRows = .Cells(i, "BU").Value
Range(Cells(i, 1), Cells(i, 72)).specialcells(xlCellTypeVisible).Copy
lastrow = .Cells(.Rows.Count, 1).End(xlUp).Row + 1 ' recalculate this for the next blank row
wsSource.Cells(lastrow, 1).Resize(lngRows).PasteSpecial Paste:=xlPasteValues
End If
Next i
End With
Application.ScreenUpdating = True
End Sub
I am trying to format some numbers where some have a leading zero so that I can then search them.
I am needing to format a set of numbers where all are 6 digits and some have a leading zero. I then have a separate code search those numbers for a specific one so the resulting format needs to be searchable. The first code below is the formatting I can't figure out and then the search code. If I simply do an "000000" for formatting I don't believe it works for my search anymore as those now become Special format. Help please?
Sub (First Code)
Dim lngLastRow As Long
lngLastRow = Cells(Rows.Count, "A").End(xlUp).Row
Range("O2:P" & lngLastRow).Select 'specify the range which suits your purpose
With Selection
Selection.NumberFormat = "General"
.Value = .Value
End With
Dim SUPLCD As Range
Set SUPLCD = Range("Q2:Q")
With Selection
Selection.NumberFormat = "#"
Selection.Value = Format(Selection, "000000")
End With
End Sub
Sub Worksheet()
Dim i As Long
Dim j As Long
Dim wsCurrent As Worksheet
Set wsCurrent = ActiveSheet
Dim wsData As Worksheet
Dim rngData As Range
Set wsData = ThisWorkbook.Worksheets("Tempinterior")
Dim wsTempinterior As Worksheet
' Note that .Add will activate the new sheet so we'll
' need to reactivate the worksheet that was previously active
Set wsTempinterior = Worksheets.Add
wsTempinterior.Name = "copy"
' Find the used range in columns A to K and copy over starting
' at cell A1 of wsGalreq
Set rngData = Intersect(wsData.UsedRange, wsData.Range("A:M"))
' Copy over the first row containing column headers
j = 1
rngData.Rows(1).Copy Destination:=wsTempinterior.Cells(j, 1)
For i = 2 To rngData.Rows.Count
' Check cell of column 10 of row i and copy if matched
If rngData.Cells(i, 10).Value = "026572" Or rngData.Cells(i, 10).Value = "435740" Or rngData.Cells(i, 10).Value = "622639" Then
' Copy over to wsDalreq from row j
j = j + 1
rngData.Rows(i).Copy Destination:=wsTempinterior.Cells(j, 1)
End If
Next
End Sub
With above code, the search doesn't pull the entries with those numbers I think because they are formatted as Special.
You don't have to format Col Q to add a 0, you can accomplish your task with out formatting by using Like in your If statement. Because you are not clear about where the values are, you are formatting Col Q but searching Col J, I used Col Q.
Dim wsData As Worksheet
Set wsData = ThisWorkbook.Worksheets("Sheet1") '("Tempinterior")
Dim rngData As Range
Set rngData = Intersect(wsData.UsedRange, wsData.Range("A:M"))
Sheets.Add(After:=Sheets(Sheets.Count)).Name = "copy"
j = 1
rngData.Rows(1).Copy Destination:=Sheets("copy").Cells(j, 1) 'copy headers for rngData
For i = 2 To rngData.Rows.Count
If wsData.Cells(i, 17).Value Like "26572" Or Sheet1.Cells(i, 17).Value = "435740" Or _
Sheet1.Cells(i, 17).Value = "622639" Then
j = j + 1
rngData.Rows(i).Copy Destination:=Sheets("Copy").Cells(j, 1)
End If
Next i
End Sub
First avoid .Select and you will need to loop the change:
Sub first()
Dim lngLastRow As Long
With Worksheets("Sheet1") 'Change to your sheet
lngLastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
With .Range("O2:P" & lngLastRow) 'specify the range which suits your purpose
.NumberFormat = "General"
.Value = .Value
End With
Dim SUPLCD As Range
Set SUPLCD = .Range("Q2:Q" & lngLastRow)
Dim rng As Range
For Each rng In SUPLCD
rng.NumberFormat = "#"
rng.Value = Format(rng.Value, "000000")
Next rng
End With
End Sub
I may have up to 8 unique values in column D. I am looking for a code that will copy & paste each row with unique value to a new sheet.
So I may have up to 8 new sheets.
Could you help me to build the code that will do that?
This is what I have so far:
Option Explicit
Sub AddInstructorSheets()
Dim LastRow As Long, r As Long, iName As String
Dim wb As Workbook, ws As Worksheet, ts As Worksheet, nws As Worksheet
Dim i As Integer
Dim m As Integer
'set objects
Set wb = ActiveWorkbook
Set ws = ActiveSheet
Set ts = Sheets("Master")
'set last row of instructor names
LastRow = ws.Cells(ws.Rows.Count, "K").End(xlUp).Row
'add instructor sheets
On Error GoTo err
Application.ScreenUpdating = False
For r = 17 To LastRow 'assumes there is a header
iName = ws.Cells(r, 4).Value
With wb 'add new sheet
ts.Copy After:=.Sheets(.Sheets.Count) 'add template
Set nws = .Sheets(.Sheets.Count)
nws.Name = iName
Worksheets(iName).Rows("17:22").Delete
Worksheets("Master").Activate
Range(Cells(r, 2), Cells(r, 16)).Select
Selection.Copy
m = Worksheets(iName).Range("A15").End(xlDown).Row
Worksheets(iName).Cells(m + 1, 1).PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
End With
Next r
err:
ws.Activate
Application.ScreenUpdating = True
End Sub
The thing is that this macro is creating new sheets, which is not necessary. I only want to make following.
If you find a unique value in column D (which will have exact name as other sheet), find this sheet and paste whole row in there.
Sub CopyFromColumnD()
Dim key As Variant
Dim obj As Object
Dim i As Integer, lng As Long, j As Long
Dim sht As Worksheet, mainsht As Worksheet
Set obj = CreateObject("System.Collections.ArrayList")
Set mainsht = ActiveSheet
With mainsht
lng = .Range("D" & .Rows.Count).End(xlUp).Row
With .Range("D1", .Range("D" & lng))
For Each key In .Value
If Not obj.Contains(key) Then obj.Add key
Next
End With
End With
For i = 0 To obj.Count - 1
Set sht = Sheets.Add(After:=Sheets(Sheets.Count))
sht.Name = obj(i)
For j = 1 To lng
If mainsht.Cells(j, 4).Value = obj(i) Then
mainsht.Rows(j).EntireRow.Copy Destination:=Range("A1")
Exit For
End If
Next
Next
End Sub
Ok, I did the workaround. I have created a list of unique values in a separate sheet.
Sub copypaste()
Dim i As Integer
Dim j As Integer
LastRow = Worksheets("Master").Range("D17").End(xlDown).Row
For i = 17 To LastRow
For j = 2 To 10
Workstream = Worksheets("Database").Cells(j, 5).Value
Worksheets("Master").Activate
If Cells(i, 4) = Worksheets("Database").Cells(j, 5).Value Then
Range(Cells(i, 2), Cells(i, 16)).Select
Selection.Copy
Worksheets(Workstream).Cells(1, 1).PasteSpecial Paste:=xlPasteValues
Else
End If
Next j
Next i
End Sub
Thank you everyone for help and your time!