I am a total newbie when it comes to visual basic and am looking for some help.
Basically I've already written code that takes a data entry sheet and dumps it into a datasheet in the next available free row.
I am now trying to create a separate page in which users can amend details - to get the details to feed into this page I've just simply used VLookups but now I wish to have a macro that will lookup a particular value in a series of rows and then replace that row with the amended row from the new sheet.
Any help in this would be greatly appreciated as I am massively struggling.
New Information:
I've put this code together to try to demonstrate what I am trying to achieve - I know this code is not very good and won't achieve it but hoping it goes some way to explaining what I'm trying to do.
I'm trying to take "ID" which is located in Sheets("LCH").range("E16"), look for it in Sheets("Data") It will be located in the first column then upon finding the value I want to paste all information in SourceRange to the right of it.
Please see code below:
Sub Button1_Click()
Dim rng1 As Range
Dim ID As Range
Dim DestSheet As Worksheet
Dim SourceRange As Range
Dim DestRange As Range
Set DestSheet = Sheets("Data")
Set ID = Sheets("LCH").Range("E16")
Set SourceRange = Sheets("LCH").range(E17:E90)
Set DestRange = Sheets("Data").Range("A1:ZZZ500")
DestSheet.Activate
Set rng1 = ActiveSheet.Find(ID, Cells(1, ActiveCell.Column), xlFormulas, xlWhole, , xlNext)
SourceRange.Copy
DestRange.PasteSpecial _
Paste:=xlPasteValuesAndNumberFormats, _
operation:=xlPasteSpecialOperationNone, _
skipblanks:=False, _
Transpose:=True
Application.CutCopyMode = False
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
If Not rng1 Is Nothing Then
Application.Goto rng1
Else
MsgBox "10 not found"
End If
End Sub
Sub Tester()
Dim f As Range, IDCell As Range
Set IDCell = Sheets("LCH").Range("E16")
Set f = Sheets("Data").Columns(1).Find(IDCell.Value, _
LookIn:=xlValues, lookat:=xlWhole)
If Not f Is Nothing Then
Sheets("LCH").Range("E17:E90").Copy
f.Offset(0, 1).PasteSpecial Paste:=xlPasteValuesAndNumberFormats, _
Transpose:=True
Application.CutCopyMode = False
Else
MsgBox "ID '" & IDCell.Value & "' not found on data sheet", vbExclamation
End If
End Sub
Related
I have 2 wb to_update_example_1 and purchasing_list
basically what I am trying to do is to a loop row by row on workbook to_update_example_1 if the same name is found to copy the a variable to the purchasing_list workbook.
However it keeps giving me error 91 at the searching portion and I would need an advice how do I write vVal2(which is the Qty) to Purchasing list workbook the column is just beside the found name so I tried to use active cell offset but didn't work too
any advice is appreciated thanks
Sub Macro1()
Application.ScreenUpdating = False
Dim x As Integer
Dim vVal1, vVal2 As String
Numrows = Range("A1", Range("A1").End(xlDown)).Rows.Count ' Set numrows = number of rows of data.
Range("A1").Select ' Select cell a2.
For x = 1 To Numrows ' Establish "For" loop to loop "numrows" number of times.
vVal1 = Cells(x, 8)
vVal2 = Cells(x, 7)
Windows("Purchasing List.xls").Activate
ActiveSheet.Cells.Find(What:=vVal1, After:=ActiveCell, LookIn:=xlValues, _
LookAt:=xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Row
''write to Qty cell beside the found name ActiveCell.Offset(0, -2) = vVal2
Windows("To_update_example_1.xlsm").Activate
''''''''ActiveCell.Offset(1, 0).Select
Next
Application.ScreenUpdating = True
End Sub
When using the Find function, it's recommended if you set a Range object to the Find result, and also prepare your code for a scenario that Find didn't find vVal1 in "Purchasing List.xls" workbook. You can achieve it by using the following line If Not FindRng Is Nothing Then.
Note: avoid using Select, Activate and ActiveSheet, instead fully qualify all your Objects - see in my code below (with comments).
Modified Code
Option Explicit
Sub Macro1()
Application.ScreenUpdating = False
Dim x As Long, Numrows As Long
Dim vVal1 As String, vVal2 As String
Dim PurchaseWb As Workbook
Dim ToUpdateWb As Workbook
Dim FindRng As Range
' set workbook object of "Purchasing List" excel workbook
Set PurchaseWb = Workbooks("Purchasing List.xls")
' set workbook object of "To_update_example_1" excel workbook
Set ToUpdateWb = Workbooks("To_update_example_1.xlsm")
With ToUpdateWb.Sheets("Sheet1") ' <-- I think you are trying to loop on "To_update_example_1.xlsm" file , '<-- change "Sheet1" to your sheet's name
' Set numrows = number of rows of data.
Numrows = .Range("A1").End(xlDown).Row
For x = 1 To Numrows ' Establish "For" loop to loop "numrows" number of times
vVal1 = .Cells(x, 8)
vVal2 = .Cells(x, 7)
' change "Sheet2" to your sheet's name in "Purchasing List.xls" file where you are looking for vVal1
Set FindRng = PurchaseWb.Sheets("Sheet2").Cells.Find(What:=vVal1, LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByColumns)
If Not FindRng Is Nothing Then '<-- make sure Find was successful finding vVal1
' write to Qty cell beside the found name ActiveCell.Offset(0, -2) = vVal2
' Not sure eactly what you want to do now ???
Else ' raise some kind of notification
MsgBox "Unable to find " & vVal1, vbInformation
End If
Next x
End With
Application.ScreenUpdating = True
End Sub
Edited to account for OP's comment about where to search and write values
ShaiRado already told you where the flaw was
here's an alternative code
Option Explicit
Sub Macro1()
Dim cell As Range, FindRng As Range
Dim purchListSht As Worksheet
Set purchListSht = Workbooks("Purchasing List.xls").Worksheets("purchaseData") '(change "purchaseData" to your actual "purchase" sheet name)
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
With Workbooks("to_update_example_1").Sheets("SourceData") ' reference your "source" worksheet in "source" workbook (change "SourceData" to your actual "source" sheet name)
For Each cell In .Range("H1", .Cells(.Rows.Count, 8).End(xlUp)).SpecialCells(xlCellTypeConstants) ' loop through referenced "source" sheet column "H" not empty cells
Set FindRng = purchListSht.Columns("G").Find(What:=cell.Value, LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByColumns) ' try finding current cell content in "purchase" sheet column "G"
If Not FindRng Is Nothing Then FindRng.Offset(, -2).Value = cell.Offset(, -1).Value ' if successful, write the value of the cell one column left of the current cell to the cell two columns to the left of found cell
Next
End With
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
This script is used to filter column I data, copy it and move it to a new worksheet based on the first visible cell in I2 (header is I1). Afterwards, I would want to Loop it to go through the rest of the autofilter criteria without actually referencing anything, just running through the list. It seems to be working but it unselects all the data in Column I and doesn't name the sheet properly because the data results in blank rows. Can anyone help me?
I just need the code to do this:
Autofilter by column I (Manager), select all cells, create new worksheet, paste filtered manager data from raw data into that new worksheet, name worksheet based on first visible cell value in column I (manager name), and then loop through the rest of the filter list without having to reference manager names, just a Next kind of Looping feature until the whole list has been run-through.
Sub Format()
Set My_Range = Worksheets("Sheet1").Range("A1:I" & LastRow(Worksheets("Sheet1")))
Set Name = FirstVisibleValue(ActiveSheet, 2, 9)
Cells.Select
Do
'Filter and set the filter field and the filter criteria :
My_Range.AutoFilter Field:=9, Criteria1:=ActiveCell.Value
'Add a new Worksheet
Set WSNew = Worksheets.Add(After:=Sheets("Sheet1"))
WSNew.Name = Name
'Copy/paste the visible data to the new worksheet
My_Range.Parent.AutoFilter.Range.Copy
With WSNew.Range("A1")
.PasteSpecial xlPasteValues
Cells.Select
End With
'Close AutoFilter
My_Range.Parent.AutoFilterMode = False
'Restore ScreenUpdating, Calculation, EnableEvents, ....
My_Range.Parent.Select
ActiveWindow.View = ViewMode
If Not WSNew Is Nothing Then WSNew.Select
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = CalcMode
End With
Loop
End Sub
Function LastRow(sh As Worksheet)
On Error Resume Next
LastRow = sh.Cells.Find(What:="*", _
After:=sh.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlValues, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
On Error GoTo 0
End Function
Try this instead - cut down a lot of unnecessary things and cleaned it up a bit. To make sure we don't already have a worksheet for that manager, we use the UDF WorksheetExists().
Also I try to avoid Do/Loop loops when I can - just use a For loop for the entire column of I.
Option Explicit
Sub Format()
Dim sht As Worksheet, WSNew As Worksheet
Dim My_Range As Range
Dim i As Long, lastrow As Long
Set sht = ThisWorkbook.Worksheets("Sheet1")
lastrow = sht.Cells(sht.Rows.Count, "I").End(xlUp).Row
Set My_Range = sht.Range("A1:I" & lastrow)
For i = 2 To lastrow
If WorksheetExists(sht.Range("I" & i).Value) = False Then
Set WSNew = Worksheets.Add(After:=Sheets("Sheet1"))
WSNew.Name = sht.Range("I" & i).Value
My_Range.AutoFilter Field:=9, Criteria1:=sht.Range("I" & i).Value
My_Range.Parent.AutoFilter.Range.Copy
WSNew.Range("A1").PasteSpecial xlPasteValues
End If
Next i
My_Range.Parent.AutoFilterMode = False
Application.CutCopyMode = False
End Sub
Function WorksheetExists(sName As String) As Boolean
WorksheetExists = Evaluate("ISREF('" & sName & "'!A1)")
End Function
I have a code that successfully looks into an external file and copy/pastes the rows that contain that particular condition into the current workbook. For example I am searching for Singapore in the external workbook called Active master project file and copy all the rows containing Singapore to the current workbook that is open.
A problem that occurs is that when I run the same code twice, a border line will exist on the last row of the worksheet. For example when I run the code, it will copy paste the information containing Singapore to the current worksheet called "New Upcoming Projects":
However, when I run the code again it will create a border line on each column such as the image shown below:
And the code that I have for now is:
Sub UpdateNewUpcomingProj()
Dim wb1 As Workbook, wb2 As Workbook
Dim ws1 As Worksheet, ws2 As Worksheet
Dim copyFrom As Range
Dim lRow As Long '<~~ Not Integer. Might give you error in higher versions of excel
Dim strSearch As String
Set wb1 = Application.Workbooks.Open("U:\Active Master Project.xlsm")
Set ws1 = wb1.Worksheets("New Upcoming Projects")
strSearch = "Singapore"
With ws1
'~~> Remove any filters
.AutoFilterMode = False
'~~> I am assuming that the names are in Col A
'~~> if not then change A below to whatever column letter
lRow = .Range("A" & .Rows.Count).End(xlUp).Row
With .Range("A1:A" & lRow)
.AutoFilter Field:=1, Criteria1:="=*" & strSearch & "*"
Set copyFrom = .Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow
End With
.AutoFilterMode = False
End With
'~~> Destination File
Set wb2 = ThisWorkbook
Set ws2 = wb2.Worksheets("New Upcoming Projects")
With ws2
If Application.WorksheetFunction.CountA(.Cells) <> 0 Then
lRow = .Cells.Find(What:="*", _
After:=.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
Else
lRow = 2
End If
copyFrom.Copy .Rows(lRow)
.Rows.RemoveDuplicates Array(2), xlNo
End With
End Sub
Is there any improvement or additional codes that I have to add in so that the border line would disappear?
As EyePeaSea said you can remove the border by vba code, e.g.
ThisWorkbook.Worksheets("XY").Range("A1", "Z99").Borders.LineStyle = xlNone
In your case the code should be (untested)
copyFrom.Borders.LineStyle = xlNone
after you copied the row
I assume this formatting is coming from the source worksheet. If so, you could PasteSpecial to just paste values, keeping the destination formatting. To do so, simply replace
copyFrom.Copy .Rows(lRow)
with
copyFrom.Copy
.Rows(lRow).PasteSpecial xlPasteValues, xlPasteSpecialOperationNone, False, False
If you do need some formatting from the source sheet, you can use xlPasteAllExceptBorders instead of xlPasteValues.
Paste Special, this will paste to the first empty cell in column A
copyfrom.Copy
ws2.Cells(ws2.Rows.Count, "A").End(xlUp).Offset(1).PasteSpecial xlPasteValues
Application.CutCopyMode = 0
You can add this line after removing the duplicates
.UsedRange.Offset(lRow).Borders.Value = 0
This will remove any borders from the inserted rows
p.s.: I still dont understand where these borders came from, most probably from the original worksheet.. :)
At the end of the code,
please add a new line to format paint of the 3rd row.
So basically before the last two lines
wb1.Select ' please make sure you select the correct one wb1 or wb2 here and try again
Rows("3:3").Select
Selection.Copy
Rows("4:10000").Select
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
end with
end sub 'This is the last line of your code
Im an intern at a company where they do a lot of DCR and Inductance readings and have all the values on text files. Ive managed to use VBA to import those text files into an excel spreadsheet however now I need to start manipulating that data. I'm trying to write some code that will loop through an entire column and search for the string "**DCR" and then give me the data that is in the cell offset (1,3), copy, and then paste it to a different range within the same workbook. I've written code where is searches for the first instance of the string and then copies and pastes that data that I need into the range, but then it stops there. The Do Loop code that I wrote gives me an infinite loop and doesnt work. Here is my code so far.
Sub Button2_Click()
Dim rng1 As Range
Dim strSearch As String
strSearch = "**DCR"
Set rng1 = Range("A:A").Find(strSearch, , xlValues, xlWhole)
If Not rng1 Is Nothing Then
rng1.Offset(1, 3).Copy
Range("N11").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("O11").Select
Do
Set rng1 = Range("A:A").FindNext(rng1)
Loop
End If
End Sub
Can anyone tell me what I'm missing and/or doing wrong. Thank you very much!
Try this...
Sub Button2_Click()
Const DCR As String = "**DCR"
Dim rngSearch As Range
Set rngSearch = ActiveSheet.Range("A:A")
Dim rngFoundFirst As Range
Set rngFoundFirst = rngSearch.Find(DCR, LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=True)
' Anything found?
If Not rngFoundFirst Is Nothing Then
Call ProcessDcr(rngFoundFirst)
Dim rngFoundNext As Range
Set rngFoundNext = rngFoundFirst
Do
Set rngFoundNext = rngSearch.FindNext(rngFoundNext)
' If first one is found, stop looping.
If Not rngFoundNext Is Nothing Then
If rngFoundNext.Address = rngFoundFirst.Address Then
Exit Do
End If
Call ProcessDcr(rngFoundNext)
End If
Loop Until rngFoundNext Is Nothing
End If
Set rngFoundNext = Nothing
Set rngFoundFirst = Nothing
Set rngSearch = Nothing
End Sub
Sub ProcessDcr(rngFound As Range)
Call rngFound.Offset(1, 3).Copy
Call Range("N11").PasteSpecial(Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False)
End Sub
You'll need to move the Do-Loop: basically loop as long as there are results to be found, quit when no result is found. But the code will still loop, cause findNext will continue to find the next result, even if it has already found it. So you have to keep to keep track of your first result.
You'll probably want to increment the location to which you copy.
Keep in mind that copy and paste is expensive in excel, a better and faster way is to copy the cell value.
Dim strSearch As String
Dim rng1 As Excel.Range
Dim firstrng1 As Excel.Range
Dim rowNumber as Integer
rowNumber = 11;
strSearch = "**DCR"
Set rng1 = Range("A:A").Find(strSearch, , xlValues, xlWhole)
If rng1 Is Nothing Then Exit Sub
Set firstrng1 = rng1
Do
Range("N" & rowNumber).Value = rng1.Offset(1, 3)
rowNumber = rowNumber + 1
Set rng1 = Range("A:A").FindNext(rng1)
If rng1.Address = firstrng1.Address Then Exit Do
Loop
Hi all the noob is back again. I am doing a copy paste job of data from one worksheet into another which is hidden but there is a danger that data will be duplicated if not checked against what has already been pasted. So far, what I have done is to insert a code in the worksheet I am copying to, to stop the duplication but the complication I now have is that the validation is checking every bit of data throughout the column from start to end and this is about 5000< entries. Column B has the report date which is the same for all entries belonging to the same month end. So it will have say 5000 entries with 30/1/13....another with 28/02/13 etc. Ideally, I want to only check once in Column B where the report date is entered and if the date matches to what I want to copy, then reject the entire copy paste process instead of validating each individual entry in the copy range. Here is the code I am working with. I hope I'm making sense & thank you very much for helping.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim r As Range
Dim ans As String
Const myCol As Long = 2
If Intersect(Target, Columns(myCol)) Is Nothing Then Exit Sub
Application.EnableEvents = False
For Each r In Intersect(Target, Columns(myCol))
If Application.CountIf(Columns(myCol), r.Value) > 1 Then
MsgBox (r.Value & " already exsists")
r.ClearContents
End If
Next
Application.EnableEvents = True
End Sub
thats my code including the remove duplicates but it aint working. I have tried it
Sub LoadData_toTable()
Dim ws1LRow As Long, ws2LRow As Long
Dim ws1 As Worksheet, ws2 As Worksheet
Application.ScreenUpdating = False
Set ws1 = ThisWorkbook.Sheets("RAW DATA")
Set ws2 = ThisWorkbook.Sheets("DATA INPUT")
With ws1
ws1LRow = .Cells.Find(What:="*", _
After:=.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row + 1
End With
With ws2
ws2LRow = .Range("G" & .Rows.Count).End(xlUp).Row
.Range("A2:AR" & ws2LRow).Copy
ws1.Range("A" & ws1LRow).PasteSpecial xlPasteValues
Application.CutCopyMode = False
Application.ScreenUpdating = True
End With
With ws1
ws1.Range("A:A").RemoveDuplicates
End With
For Each WS In ThisWorkbook.Worksheets
For Each PT In WS.PivotTables
PT.RefreshTable
Next PT
Next WS
MsgBox "Loading month's data complete!"
End Sub
A very-long-calculation-time-solution would be to create an array containing only data not equal to that already in the sheet (you would have to iterate each copied element and compare to each element in the hidden sheet).
Otherwise you could format the duplicated data in some way, then iterate and remove all the formatted data except the first (which you would re-format as before). Example:
Selection.NumberFormat = "0.0 ""double""" '<--- this could be made also with colors
Selection.FormatConditions.AddUniqueValues
Selection.FormatConditions(Selection.FormatConditions.count).SetFirstPriority
Selection.FormatConditions(1).DupeUnique = xlDuplicate
ExecuteExcel4Macro "(2,1,""0.0 ""double"""")"
Selection.FormatConditions(1).StopIfTrue = False
Then inside iteration
cells(x,y).select
if counted_formatted_data = 1 then
Selection.NumberFormat = "0.0 " '<--- back to the previous formatting
else
selection.delete
end if
Of course it is better if you do this without selecting anything.