I've created an Excel document with a sheet, named "Plakken". This sheet contains a button which paste a table, that the user copied from an intranet page, on to the sheet "Template (2)".
In the example below, you can see the table on "template (2)"
What i like to do now, is copy some data from the pasted table to sheet "opslaan", the data i want to copy is:
Artikelnummer (article number)
Artikelnaam (article name)
datum (date)
These are the 3 left columns, for example:
But the data in the table is seperated with rows containing the word "vulgebied".
Example:
I'm searching for a way to only copy all the data listed above, and paste them on the sheet "opslaan".
The table is different every time, sometimes there are more or few lines between the "vulgebied" row, but the style of the table is always the same.
Edit:
I think something that might work is:
Option Explicit
Sub DeleteRow()
Dim i As Long
Dim rng As Range
With ActiveWorkbook.Sheets(1)
For i = 100000 To 1 Step -1
With .Cells(i, "C")
If .Value = "Vulgebied" Then
If rng Is Nothing Then
Set rng = .Cells
Else
Set rng = Application.Union(rng, .Cells)
End If
End If
End With
Next i
If Not rng Is Nothing Then rng.EntireRow.Delete
End With
End Sub
But because the word "vulgebied" contains a different number after the word, i don't know how to solve that..
Example: https://files.fm/u/n4k4z6yz
In order to find cells that might contain the word "Vulgebied", use the function Instr.
Modified Code
Option Explicit
Sub DeleteRow()
Dim i As Long
Dim DelRng As Range
Application.ScreenUpdating = False
With ThisWorkbook.Sheets("Template (2)")
For i = 100000 To 1 Step -1
If InStr(.Range("C" & i).Value, "Vulgebied") > 0 Then
If DelRng Is Nothing Then
Set DelRng = .Range("C" & i)
Else
Set DelRng = Application.Union(DelRng, .Range("C" & i))
End If
End If
Next i
If Not DelRng Is Nothing Then DelRng.EntireRow.Delete
End With
Application.ScreenUpdating = False
End Sub
Note: a safer way to make sure "Vulgebied" is found within a cell is by using the LCase function (converts the all characters of the word to lower case), see below:
If InStr(LCase(.Range("C" & i).Value), "vulgebied") > 0 Then
Related
I need to fill a range from 10,000 all the way until the end of the column. I have the lRow variable that is finding the last row, and then I have the IF loop that is filling the range just like I need to. The clear contents part is to remove any previous values and fill new ones. The Range("E2").Value = 1 is there to start the series.
The problem is I can't get it to fill the Range("F2:F" & lRow) in a step value of 10,000. The macro just fills out in a step value of 1. Any ideas?
I've tried recording macros but it never works quite right. It needs to be sort of dynamic as the list will grow over time.
This is what it should look like:
Sub MLOS_PriorityTable_StepValues()
Dim ws As Worksheet
Dim lRow As Long
Dim featOrder As Range
Dim Style As Range
Dim dataRange As Range
Dim currentArea As Range
Set ws = ActiveSheet
Set featOrder = ws.Range("A1:ZZ1").Find("FeatureOrder")
Set Style = ws.Range("A1:ZZ1").Find("Style")
Range("E2:E1000").ClearContents
Range("F2:F1000").ClearContents
Range("E2").Value = 1
Range("F2").Value = 10000
lRow = Cells(Rows.Count, Style.Column).End(xlUp).Row
On Error Resume Next
Set dataRange = Range("E2:E" & lRow).SpecialCells(xlCellTypeBlanks)
On Error GoTo 0
If Not dataRange Is Nothing Then
For Each currentArea In dataRange.Areas
With currentArea
With .Offset(-1, 0).Resize(.Rows.Count + 1)
.Cells(1).AutoFill Destination:=.Cells, Type:=xlFillSeries
End With
End With
Next currentArea
End If
On Error Resume Next
Set dataRange = Range("F2:F" & lRow).SpecialCells(xlCellTypeBlanks)
On Error GoTo 0
If Not dataRange Is Nothing Then
For Each currentArea In dataRange.Areas
With currentArea
With .Offset(-1, 0).Resize(.Rows.Count + 1)
.Cells(1).AutoFill Destination:=.Cells, Type:=xlFillSeries
End With
End With
Next currentArea
End If
End Sub
Is the result of F just E*10000? It doesn't matter too much, there's a few ways to solve.
Find your last row number (which you did as lRow)
Iterate for i = 2 to lRow which will loop from the top row with data to the last
Do something in here like Range("F"&i) = Range("E"&i)*10000 assuming that is the relationship or Range("F"&i) = Range("F"&i-1)+10000
next i
it will just iterate cell by cell, make the calculation, and move on.
You may need to make it more robust if you have a script that hops around multiple sheets or workbooks so the range or cell or whatever references you use are correct.
Don't know how fast this would be vs the fill Series function but it doesn't look at face value like it would be too slow.
let me know how you get on!
Rob S
I've been successful in getting this string comparison to work with one column. I've expanded the range to two columns and it appears when viewing the locals window that the comparison is taking place. For reasons I've not been able to decipher though the if statement to change the color of the cell if the string comparison is positive does not occur.
Not getting any errors, but also not getting any response.
I've stepped through and watched the local window and everything I've observed there tells me the that the comparison is being made so I'm somewhat baffled as to what could be missing.
Sub ColourDuplicateNameTwoCol() 'Work in progress
Dim baseName As Range
Dim allName As Range
Dim cell As Range
With ThisWorkbook.Worksheets("sheet1")
Set baseName = Range("c1")
Set allName = Range("a1:b7")
For Each cell In allName.cells
If StrComp(baseName.Value, cell.Value, vbTextCompare) = 1 Then
cell.Interior.Color = vbYellow
End If
Next cell
End With
End Sub
Here is the one column working version I mention
Sub ColourDuplicateName() 'Works
Dim baseName As Range
With ThisWorkbook.Worksheets("sheet1")
Set baseName = .Range("b1")
For I = 1 To 7
If StrComp(baseName.Value, cells(I, 1).Value, vbTextCompare) = 1 Then
cells(I, 1).Interior.ColorIndex = 3
End If
Next I
End With
End Sub
Your interpretation of the return value from StrComp is incorrect. Check VBA HELP.
Option Explicit
Sub ColourDuplicateNameTwoCol() 'Work in progress
Dim baseName As Range
Dim allName As Range
Dim cell As Range
With ThisWorkbook.Worksheets("sheet1")
Set baseName = .Range("c1")
Set allName = .Range("a1:b7")
For Each cell In allName.Cells
If StrComp(baseName.Value, cell.Value, vbTextCompare) = 0 Then
cell.Interior.Color = vbYellow
End If
Next cell
End With
End Sub
The above code, which merely shows the StrComp problem you have run into, is not very dynamic. You would have to add code to remove the color, and then add it back, should baseName change. You could, of course, do this with an event Macro.
However, a more dynamic method would be to just set up Conditional Formatting. You would only have to do this once, and it could accomplish the same.
To do this in VBA code, for example:
Option Explicit
Sub ColourDuplicateNameTwoCol() 'Work in progress
Dim baseName As Range
Dim allName As Range
Dim cell As Range
With ThisWorkbook.Worksheets("sheet1")
Set baseName = .Range("c1")
Set allName = .Range("a1:b7")
End With
With baseName.FormatConditions
.Delete
.Add Type:=xlCellValue, _
Operator:=xlEqual, _
Formula1:=baseName
.Item(1).Interior.Color = vbYellow
End With
End Sub
This code will need to be modified if you have other FormatConditions for allNames which you want to retain.
I have some code that deletes rows that are not in a specified list of row numbers that are to be kept. It functions as intended.
For lRow = numRowsInBBS To 1 Step -1
lMatch = 0
On Error Resume Next
lMatch = Application.Match(lRow, ws.Range("AE4:AE" & numRows).Value, 0&)
On Error GoTo 0
If Not CBool(lMatch) Then
wsImport.Cells(lRow, 1).EntireRow.Delete
End If
Next
End Sub
However, this takes a monumental amount of time. To do this on 150 rows takes a couple of minutes of processing. I have documents that could be 1000s of rows long.
Essentially I want to delete all rows on a specified sheet EXCEPT for the row numbers specified in AE4:AE?? (This is calculated by numRows) on a different sheet.
The data range is not contiguous, AE4:AE?? could list numbers 3,4,5,33,66,101,110 as rows to keep. All other rows are to be deleted.
Is there a better way of achieving my goal here?
I hear autofilter is much faster, but don't see how I can apply it here as I am not matching a string or any content in the cells, simply the row numbers.
EDIT:
As per suggestion, I have tried the autofilter way:
Dim rowsToKeep() As Variant: rowsToKeep = ws.Range("AE4:AE" & numRows)
Dim allRows As Range: Set allRows = Range("ZZ1:ZZ" & numRowsInBBS)
With wsImport
.Range(allRows.Address).Formula = "=row()"
.Range(allRows.Address).AutoFilter Field:=1, Criteria1:=rowsToKeep, Operator:=xlFilterValues
.Range(allRows.Address).SpecialCells(xlCellTypeVisible).EntireRow.Delete
.Range(allRows.Address).AutoFilter Field:=1
End With
I am trying to:
Set the data in the range AE4:AE?? as the data for an array -
Then use ZZ as a helper column containing row numbers -
Then filter out the rows I want to keep -
Then delete all visible rows -
Then show the rows that were filtered
However, the filter is hiding everything, which suggests to me there is something wrong with rowsToKeep, and yes AE4:AE?? on the other sheet does contain values.
Try this (Untested)
Deleting rows in a loop will always be slower. What the below code does is that it stores the rows that needs to be deleted in a range object and then deletes them at the end of the loop in One go.
Dim delRng As Range
For lRow = 1 To numRowsInBBS
On Error Resume Next
lMatch = Application.Match(lRow, ws.Range("AE4:AE" & numRows).Value, 0&)
On Error GoTo 0
If Not CBool(lMatch) Then
If delRng Is Nothing Then
Set delRng = wsImport.Rows(lRow)
Else
Set delRng = Union(delRng, wsImport.Rows(lRow))
End If
End If
Next
If Not delRng Is Nothing Then delRng.Delete
Using CountIf (Untested)
Dim delRng As Range
For lrow = 1 To numRowsInBBS
If Application.WorksheetFunction.CountIf(ws.Range("AE4:AE" & numRows), lrow) > 0 Then
If delRng Is Nothing Then
Set delRng = wsImport.Rows(lrow)
Else
Set delRng = Union(delRng, wsImport.Rows(lrow))
End If
End If
Next
If Not delRng Is Nothing Then delRng.Delete
Any alternative or suggestions to Fasten the below stated code that finds cells on multiple conditions and cut paste the same to another sheet.
Sub test()
'For Move Entire Row to New Worksheet if Cell Contains Specific Text's
'Using autofilter to Copy rows that contain certain text to a sheet called commodity
Dim LR As Long
Range("A2").EntireRow.Insert Shift:=xlDown
LR = Sheets("Data").Cells(Rows.Count, "E").End(xlUp).Row
LR1 = Sheets("Commodity").Cells(Rows.Count, "A").End(xlUp).Row + 1
With Sheets("Data").Range("e:e")
.AutoFilter Field:=1, Criteria1:=("*SILVER*")
.SpecialCells(xlCellTypeVisible).EntireRow.Copy
Destination:=Sheets("Commodity").Range("A" & LR1)
.SpecialCells(xlCellTypeVisible).EntireRow.Delete
End With
With Sheets("Data").Range("e:e")
.AutoFilter Field:=1, Criteria1:=("*GOLD*")
.SpecialCells(xlCellTypeVisible).EntireRow.Copy
Destination:=Sheets("Commodity").Range("A" & LR1)
.SpecialCells(xlCellTypeVisible).EntireRow.Delete
End With
With Sheets("Data").Range("e:e")
.AutoFilter Field:=1, Criteria1:=("*MCX*")
.SpecialCells(xlCellTypeVisible).EntireRow.Copy
Destination:=Sheets("Commodity").Range("A" & LR1)
.SpecialCells(xlCellTypeVisible).EntireRow.Delete
End With
End Sub
As well as the good suggestions #ShaiRado is making, what's slowing this down is your repeated interactions with the Excel functions and interface. Ideally, you'd read the data into variables within VBA, and then, all within VBA, check for matches and prepare an output array. That way you'd only have one interaction between VBA and Excel, namely to write the output array to your target sheet. It's also costly in time to delete one row at a time, so you might be better to create just one 'delete range' and hit it all in one go.
Skeleton code to achieve this is given below (but note, it will need a 'column offset' calculation if your used range doesn't start at "A", and you might choose a more reliable function than UsedRange). You call the routine like so:
TransferData "Silver", "Gold", "MCX"
And the routine itself might like something like this:
Private Sub TransferData(ParamArray searchItems() As Variant)
Dim srcData As Variant
Dim txData() As Variant
Dim item As Variant
Dim r As Long, c As Long
Dim txIndexes As Collection
Dim delRng As Range
'Read source data into an array
'Note: I've used UsedRange as I don't know your sheet layout
srcData = ThisWorkbook.Worksheets("Data").UsedRange.Value2
'Check for matches and record index number
Set txIndexes = New Collection
For r = 1 To UBound(srcData, 1)
For Each item In searchItems
If srcData(r, 5) = item Then
txIndexes.Add r
Exit For
End If
Next
Next
'Trasfer data to output array
ReDim txData(1 To txIndexes.Count, 1 To UBound(srcData, 2))
r = 1
For Each item In txIndexes
For c = 1 To UBound(srcData, 2)
txData(r, c) = srcData(item, c)
Next
r = r + 1
Next
'Write the transfer data to target sheet
With ThisWorkbook.Worksheets("Commodity")
.Cells(.Rows.Count, "A").End(xlUp).Resize(UBound(txData, 1), UBound(txData, 2)) = txData
End With
'Delete the transfered rows
For Each item In txIndexes
With ThisWorkbook.Worksheets("Data")
If delRng Is Nothing Then
Set delRng = .Cells(item, "A")
Else
Set delRng = Union(delRng, .Cells(item, "A"))
End If
End With
Next
If Not delRng Is Nothing Then delRng.EntireRow.Delete
End Sub
I have a quandary, and I don't know if it will work better using excel VBA or not. Thinking about it I believe VBA will work best, but I don't know how to make it work.
I have two pages in a workbook, one is the form, the other is the database, I want the pulldown menu from the form to populate the rest of the form. It does... what I want then is to be able to change the value of the form press submit, and the new data will overwrite the old data.
Is this possible?
Here is the link to the sheet I'm talking about.
http://dl.dropbox.com/u/3327208/Excel/Change.xlsx
Here is the script I am working with now...it takes the sheet, copies everything to a row takes that row, moves it to the NCMR Data tab and then clears the data on the new row from the original sheet.
This code technically could work, but what I need to do is make it use the same concept, but instead of creating a new row at the end of the sheet find the original line and replace the data from B to U in whatever row it was originally in.
I know it's possible, I just don't know how.
'Copy Ranges Variable
Dim c As Variant
'Paste Ranges Variable
Dim p As Range
'Setting Sheet
Set wsInt = Sheets("Form")
Set wsNDA = Sheets("Data")
Set p = wsInt.Range("A14")
With wsInt
c = Array(.Range("B11"))
End With
For i = LBound(c) To UBound(c)
p(i + 1).Value = c(i).Value
Next
With wsNDA
Dim Lastrow As Long
Lastrow = .Range("B" & Rows.Count).End(xlUp).Row + 1
wsInt.Rows("14").Copy
With .Rows(Lastrow)
.PasteSpecial Paste:=xlPasteFormats
.PasteSpecial Paste:=xlPasteValues
.Interior.Pattern = xlNone
End With
With .Range("A" & Lastrow)
If Lastrow = 3 Then
.Value = 1
Else
.Value = Val(wsNDA.Range("A" & Lastrow - 1).Value) + 1
End If
.NumberFormat = "0#######"
End With
End With
End Sub
I found this code:
Sub CopyTest()
Dim selrow As Range, rngToCopy As Range
With Worksheets("PD DB")
Set selrow = .Range("B:B").Find(.Range("BA1").Value)
'find the cell containing the value
Set rngToCopy = Union(selrow.Offset(0, 9), selrow.Offset(0, 12))
'use offset to define the ranges to be copied
rngToCopy.Copy Destination:=Worksheets("Edit Sheet").Range("B50")
'copy and paste (without Select)
End With
End Sub
As far as I can tell this will do what I want mostly, but I can't seem to figure out where to break it up to add it where I need to to make it work the way I want it to.
What I can tell is this, it will copy and paste, but I want to make sure it will paste the data into row it finds, and not overwrite the number of said row.
Can someone help make that possible with the two scripts I have here?
Not tested, but should get you started. I added a 3rd sheet (shtMap) to hold the mmapping between the cell addresses on your form and the column numbers on the "Data" sheet. Useful to name your sheets directly in the VB editor: select the sheet and set the name in the property grid.
*EDIT:*If you want to trigger the transfer on selecting a record id from a list in Range AG3 then place this code in the code module for that worksheet:
Private Sub Worksheet_Change(ByVal Target As Range)
Static bProcessing As Boolean
Dim rng As Range
If bProcessing Then Exit Sub
Set rng = Target.Cells(1)
If Not Application.Intersect(rng, Me.Range("AG3")) Is Nothing Then
bProcessing = True
'this is where you call your macro to transfer the record
bProcessing = False
End If
End Sub
You could use something like this for the transfer:
Public Enum XferDirection
ToForm = 1
ToDataSheet = 2
End Enum
Sub FetchRecord()
TransferData XferDirection.ToForm
End Sub
Sub SaveRecord()
TransferData XferDirection.ToDataSheet
End Sub
Sub TransferData(Direction As XferDirection)
Dim rngMap As Range, rw As Range, f As Range, dataCell As Range
Dim formCell As Range, dataCol As Long, dataRow As Long
Dim sId As String
sId = shtForm.Range("AG3").Value
Set f = shtData.Columns(1).Find(sId, LookIn:=xlValues, lookat:=xlWhole)
If Not f Is Nothing Then
dataRow = f.Row
Else
'what do you want to do here?
' record doesn't exist on data sheet
MsgBox "Record '" & sId & "' not found on '" & shtForm.Name & "' !"
Exit Sub
End If
Set rngMap = shtMap.Range("A2:B10")
For Each rw In rngMap.Rows
'the cell on the edit form
Set formCell = shtForm.Range(rw.Cells(1).Value)
'column # on datasheet
Set dataCell = shtData.Cells(dataRow, rw.Cells(2).Value)
If Direction = XferDirection.ToDataSheet Then
dataCell.Value = formCell.Value
Else
formCell.Value = dataCell.Value
End If
Next rw
End Sub
Matt, there are two approaches I would take. The first is use find(), which returns a range object, then append ".row" so that you'll be able to modify the row on Sheet2 (wsNDA, I think). You may want to test that find() doesn't return Nothing.
Dim foundRow as Long
Dim foundRng as Range
set foundRng = wsNDA.find(wsInt.Range("B11").Value, ...)
If Not foundRng is Nothing Then
foundRow = foundRng.row
End If
'method without check: foundRow = wsNDA.find(wsInt.Range("B11").Value, ...).Row
The other is to use a Dictionary object. I'm not sure what you'd want for the key, but the item could be the row on the data sheet. When you make the change to what's on the form, check against the key and grab its item (the corresponding row) to determine where you need to replace the values.