I'm a VBA newbie, pretty much learning by modifying existing macros and trial and error, so I apologize if what I am asking seems bush-league.
I combined/modified some macros to pull rows from an external workbook onto my workbook based on criteria. The issue is that I am randomly being given duplicate rows, and I cannot figure out as to why. Can anyone see what the issue is? The second issue I am having is that in addition to the column AF criteria, I would like to filter so that the dates in column E fall between the dates specified in two cells on a different sheet.
I have been trying to use the line:
If DateValue.Sheets("Control")("B1") < ("E1:E" & B) < DateValue.Sheets("Control")("C1") Then
but I am either placing it incorrectly or just completely off on the coding... Can someone help me out with that?
Sub FetchComplaints()
Dim path As String
Dim FileName As String
Dim LastCell As Range
Dim Wkb As Workbook
Dim WS As Worksheet
Dim ThisWB As String
Sheets("Sheet1").Range("A2:S1000").Clear
Sheets("ComplaintsFetched").Activate
Range("A1:AP5000").Clear
ThisWB = ThisWorkbook.Name
Application.EnableEvents = False
Application.ScreenUpdating = False
path = GetFileName
Set Wkb = Workbooks.Open(FileName:=path)
For Each WS In Wkb.Worksheets
WS.Select
B = Application.CountA(Range("A:A"))
If B = 0 Then
Else
For Each cell In Range("AF1:A" & B)
If cell.Value = True Or cell.Value = "Written" Then
Anum = Application.CountA(Workbooks(ThisWB).Sheets("ComplaintsFetched").Range("A:A")) + 1
cell.EntireRow.Copy Workbooks(ThisWB).Sheets("ComplaintsFetched").Range("A" & Anum)
End If
Next cell
End If
Next WS
Wkb.Close False
Application.EnableEvents = True
Application.ScreenUpdating = True
Set Wkb = Nothing
Set LastCell = Nothing
Set LastCell = Nothing
GetFileName is a function which retrieves the path.
Thanks for any help, and sorry if I am missing something very simple.
Try to use this syntax:
If Sheets("Control").Range("B1").Value < Sheets("Control").Range("C" & B).Value ...
Multiple conditions should be combined using And.
Related
I am trying to write a vba script that will allow me to vlookup values from Sheet(3) to different Sheet(i) - and paste it on range"R2" on the Sheet(i) - I also want it to go to the end of the values in Column M on Sheet(i) [if this is possible]. I basically want to run through all the different "i" sheets on the workbook. Sheet (3) has all the data that needs to be copied on all the other "i" sheets.
I keep getting an error with my code below.
Sub CopyTableau1Data()
Dim wka As Worksheet
Dim wkb As Worksheet
ShtCount = ActiveWorkbook.Sheets.Count
For i = 9 To ShtCount
With ThisWorkbook
Set wka = .Sheets(i)
Set wkb = .Sheets(3)
End With
Worksheets(i).Activate
If IsError(Application.WorksheetFunction.VLookup(wka.Range("M2"), wkb.Range("E:T"), 14, 0)) Then
wka.Range("R2").Value = ""
Else
wka.Range("R2").Value = Application.WorksheetFunction.VLookup(wka.Range("M2"), wks.Range("E:T"), 14, 0)
End If
Next i
End Sub
IsError does not work with Application.WorksheetFunction.VLookup or WorksheetFunction.VLookup, only with Application.VLookup.
It is faster and easier to return Application.Match once to a variant type variable and then test that for use.
dim am as variant
'are you sure you want wkb and not wks here?
am = Application.match(wka.Range("M2"), wkb.Range("E:E"), 0)
If IsError(am) Then
wka.Range("R2") = vbnullstring
Else
'are you sure you want wks and not wkb here?
wka.Range("R2") = wks.cells(am, "R").value
End If
Note the apparent misuse of wkb and wks in two places. I don't see the point of looking up a value in one worksheet, testing that return then using the results of the test to lookup the same value in another worksheet.
You can use the following code:
Sub CopyTableau1Data()
Dim wka As Worksheet
Dim wkb As Worksheet, i As Integer
ShtCount = ActiveWorkbook.Sheets.Count
For i = 9 To ShtCount
With ThisWorkbook
Set wka = .Sheets(i)
Set wkb = .Sheets(3)
End With
Worksheets(i).Activate
wka.Range("R2") = aVL(i)
Next i
End Sub
Function aVL(ByVal wsno As Integer) As String
On Error GoTo errhandler:
aVL =
Application.WorksheetFunction.VLookup(ActiveWorkbook.Worksheets(wsno).Range("M2"),
ActiveWorkbook.Worksheets(3).Range("E:T"), 14, False)
errhandler:
aVL = ""
End Function
When you try to check an error by isError, program flow can immediately return from the sub depending on the error. You could use on error in your sub to prevent that but this would only handle the first error. By delegating the error handling to a function you can repeatedly handle errors in your loop.
I assumed you wanted to use wkb.Range("E:T") instead of wks.Range("E:T").
I need help modifying a macro that matches the part number (Column C) between two sheets in different workbooks. Then it pastes the info from 'Original' sheet from the range P9:X6500 into the 'New' sheet into the range P9:X6500. The first sheet 'Original' in column C range C9:C6500 is the matching part number column. The 'New' sheet has the same column C with the part number to match. I only want match and paste the visible values.
I originally had this macro code which copy pastes only visible values from one workbook to another that I would like to modify it to match and copy paste:
Sub GetDataDemo()
Const FileName As String = "Original.xlsx"
Const SheetName As String = "Original"
FilePath = "C:\Users\me\Desktop\"
Dim wb As Workbook
Dim this As Worksheet
Dim i As Long, ii As Long
Application.ScreenUpdating = False
If IsEmpty(Dir(FilePath & FileName)) Then
MsgBox "The file " & FileName & " was not found", , "File Doesn't Exist"
Else
Set this = ActiveSheet
Set wb = Workbooks.Open(FilePath & FileName)
With wb.Worksheets(SheetName).Range("P9:X500")
On Error Resume Next
.SpecialCells(xlCellTypeVisible).Copy this.Range("P9")
On Error GoTo 0
End With
End If
ThisWorkbook.Worksheets("NEW").Activate
End Sub
Also here is what I want it to look like:
Original
NEW
I appreciate the help!
try the following where it copies the range from one sheet to the other. You can break up With wb.Worksheets(SheetName).Range("P9:X500") into With wb.Worksheets(SheetName) then use .Range("P9:X500").Copy this.Range("P9") inside the With statement. Avoid using names like i or ii or this and use something more descriptive. The error handling is essentially only dealing with Sheets not being present and i think better handling of that scenario could be done. Finally, you need to turn ScreenUpdating back on to view changes.
Option Explicit
Public Sub GetDataDemo()
Const FILENAME As String = "Original.xlsx"
Const SHEETNAME As String = "Original"
Const FILEPATH As String = "C:\Users\me\Desktop\"
Dim wb As Workbook
Dim this As Worksheet 'Please reconsider this name
Application.ScreenUpdating = False
If IsEmpty(Dir(FILEPATH & FILENAME)) Then
MsgBox "The file " & FILENAME & " was not found", , "File Doesn't Exist"
Else
Set this = ActiveSheet
Set wb = Workbooks.Open(FILEPATH & FILENAME)
With wb.Worksheets(SHEETNAME)
'On Error Resume Next ''Not required here unless either of sheets do not exist
.Range("P9:X500").Copy this.Range("P9")
' On Error GoTo 0
End With
End If
ThisWorkbook.Worksheets("NEW").Activate
Application.ScreenUpdating = True ' so you can see the changes
End Sub
UPDATE: As OP wants to match between sheets on column C in both and paste associated row information across (Col P to Col X) second code version posted below
Version 2:
Option Explicit
Public Sub GetDataDemo()
Dim wb As Workbook
Dim lookupRange As Range
Dim matchRange As Range
Set wb = ThisWorkbook
Set lookupRange = wb.Worksheets("Original").Range("C9:C500")
Set matchRange = wb.Worksheets("ThisSheet").Range("C9:C500")
Dim lookupCell As Range
Dim matchCell As Range
With wb.Worksheets("Original")
For Each lookupCell In lookupRange
For Each matchCell In matchRange
If Not IsEmpty(matchCell) And matchCell = lookupCell Then 'assumes no gaps in lookup range
matchCell.Offset(0, 13).Resize(1, 9).Value2 = lookupCell.Offset(0, 13).Resize(1, 9).Value2
End If
Next matchCell
Next lookupCell
End With
ThisWorkbook.Worksheets("NEW").Activate
Application.ScreenUpdating = True
End Sub
You may need to amend a few lines to suit your environment e.g. change this to meet your sheet name (pasting to).
Set matchRange = wb.Worksheets("ThisSheet").Range("C9:C500")
So I am basically trying to insert a comment and color the cell that basically meets the criteria that I set in my code. I searched all over but cant seem to find a viable solution.
Here is the code that I have so far and I mentioned in the code below where I would like the color and comment to be. The way I have this macro set up is that it gets "Called" from the Worksheet. I used the Selection_Change function. So I have a range where in one column someone enters data and then whatever data is entered the following macro runs and checks to see if it is within limits.
If it is not within the limits that are set in the excel sheet ("M7" and "M19"), I would like a color to highlight that certain cell and a set comment in that cell. How would I go about this? I really appreciate the help. Thank you!
Also I found a code online and my problem is that when i use the
ActiveCell.AddComment ("Text")
I keep getting an error, and also after I enter my data point and I press enter, the comment goes into the next cell.
Here is the macro that gets called:
Option Explicit
Public Sub OutofControlRestofData()
Dim lRow As Long
Dim lstRow As Long
Dim data As Variant
Dim ul As Variant
Dim ll As Variant
Dim wb As Workbook
Dim ws As Worksheet
With Application
.ScreenUpdating = True
.EnableEvents = True
.DisplayAlerts = True
End With
Set ws = Sheets(2)
ws.Select
lstRow = WorksheetFunction.Max(1, ws.Cells(Rows.Count, "R").End(xlUp).Row)
For lRow = 1 To lstRow
data = Cells(lRow, "E").Value
ul = Range("M7")
ll = Range("M19")
If data > ul Or data < ll Then
If IsNumeric(data) = True And data Like "" = False Then
MsgBox ("There was an Out of Control Point at " & Cells(lRow, "C").Value)
'THIS IS WHERE I THINK THE COMMENTING AND COLOR CODE WOULD BE
End If
End If
Next lRow
End Sub
Also here is the code that Calls the Macro:
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Target.Worksheet.Range("E39:E138")) Is Nothing Then
Run ("OutofControlRestofData")
End If
End Sub
A few things to note.
You should practice using tab to "nest" your If statements. Makes
it clearer to see.
You can go ahead and combine the two Subs. Just make sure you put the code in the Sheet's code page (not in a workbook module).
You don't need a loop if you already have a "Target" as that is the cell (Range) you want to check anyways.
You have defined your Change sub to only work if the data entry is between E39 and E138. Will this always be the case? Consider using the entire column E if you want more flexibility to grow your sheet and data.
Code:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim ws As Worksheet
Set ws = Sheets(2)
If Not Intersect(Target, ws.Range("E39:E138")) Is Nothing Then
Dim lRow As Long
Dim lstRow As Long
Dim data As Variant
Dim ul As Variant
Dim ll As Variant
Dim wb As Workbook
Dim ws As Worksheet
With Application
.ScreenUpdating = True
.EnableEvents = True
.DisplayAlerts = True
End With
data = Target.Value
ul = Range("M7").Value
ll = Range("M19").Value
If data > ul Or data < ll Then
If IsNumeric(data) = True And data Like "" = False Then
MsgBox ("There was an Out of Control Point at " & Target.Address)
Target.Interior.Color = RGB(255, 0, 0)
Target.AddComment ("This is an Out of Control Point")
End If
End If
End If
End Sub
Just to be on the safe side, I'd recommend changing your code here to include value:
data = Range("E" & lRow).Value
ul = Range("M7").Value
ll = Range("M19").Value
Then in the spot where you want to do the color/comment stuff:
Range("E" & lRow).Interior.Color = RGB(255, 0, 0)
Range("E" & lRow).AddComment("This is an Out of Control Point")
I'm able to import worksheets successfully to my workbook. But is it possible to just import the columns that I want? The data is really huge and I don't want to have the trouble to go through every part of the cells.
Below are my codes:
Sub ImportSheet()
Dim wb As Workbook
Dim activeWB As Workbook
Dim sheet As Worksheet
Dim FilePath As String
Dim oWS As String
Set activeWB = Application.ActiveWorkbook
FilePath = "C:\Report.xlsx"
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set wb = Application.Workbooks.Open(FilePath)
wb.Sheets("Report").Copy After:=activeWB.Sheets(activeWB.Sheets.Count)
activeWB.Activate
wb.Close False
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
Not sure if I'm breaking protocol here but this is a completely different approach and the option to Add Another Answer was there. This method uses the 'copy to new worksheet' approach which should be easier on limited resources.
Sub ImportSheet()
Dim iWB As Workbook, aWB As Workbook, ws As Worksheet
Dim FilePath As String, v As Long, vCOLs As Variant
Application.ScreenUpdating = False
Application.DisplayAlerts = False
FilePath = "C:\Report.xlsx"
vCOLs = Array(1, 13, 6, 18, 4, 2) 'columns to copy in this order
Set aWB = Application.ActiveWorkbook
With aWB
.Sheets.Add after:=.Sheets(.Sheets.Count)
Set ws = .Sheets(.Sheets.Count)
'.name = "Report" 'you can name the new ws but do NOT duplicate
End With
Set iWB = Application.Workbooks.Open(FilePath)
With iWB.Sheets("Report").Cells(1, 1).CurrentRegion
.Cells = .Cells.Value
For v = LBound(vCOLs) To UBound(vCOLs)
.Columns(vCOLs(v)).Copy Destination:=ws.Cells(1, v + 1)
Next v
End With
iWB.Close False
Set iWB = Nothing
Set ws = Nothing
Set aWB = Nothing
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
My primary concern here is not knowing the layout of the 'Report' worksheet. The boundaries of the .CurrentRegion are dictated by the first fully blank column to the right and the first fully blank row down. A block of data rarely has this but worksheets called Report often do.
You are closing the freshly opened workbook (without saving or warnings) after the copy so I would suggest that you loop through the columns you do not want and delete then prior to the copy. Incorporate this snippet into your existing code
Dim v As Long, vNoCopy As Variant, wb As Workbook
vNoCopy = Array(1, 3, 5, 7) 'should in ascending order (reversed below)
With wb.Sheets("Report")
.Cells = .Cells.Value 'just in case there are referenced formulas involved
For v = UBound(vNoCopy) To LBound(vNoCopy) Step -1
.Columns(vNoCopy(v)).EntireColumn.Delete
Next v
wb.Sheets("Report").Copy After:=activeWB.Sheets(activeWB.Sheets.Count)
End With
wb.Close False
That should remove columns A, C, E & G from the report before copying. Closing without saving should leave the original Report.xlsx unaffected.
I am trying to loop through some columns in a row and create new worksheets with the name of the value of the current column/row that I am in.
Sub test()
Range("R5").Select
Do Until IsEmpty(ActiveCell)
Sheets.Add.Name = ActiveCell.Value
ActiveCell.Offset(0, 1).Select
Loop
End Sub
This code creates the first one correctly starting at R5 but then it appears that the macro switches to that worksheet and doesn't complete the task.
The Sheets.Add automatically moves your selection to the newly created sheet (just like if you insert a new sheet by hand). In consequence the Offset is based on cell A1 of the new sheet which now has become your selection - you select an empty cell (as the sheet is empty) and the loop terminates.
Sub test()
Dim MyNames As Range, MyNewSheet As Range
Set MyNames = Range("R5").CurrentRegion ' load contigeous range into variable
For Each MyNewSheet In MyNames.Cells ' loop through cell children of range variable
Sheets.Add.Name = MyNewSheet.Value
Next MyNewSheet
MyNames.Worksheet.Select ' move selection to original sheet
End Sub
This will work better .... you assign the list of names to an object variable of type Range and work this off in a For Each loop. After you finish you put your Selection back to where you came from.
Sheets.Add will automatically make your new sheet the active sheet. Your best bet is to declare variables to your objects (this is always best practice) and reference them. See like I've done below:
Sub test()
Dim wks As Worksheet
Set wks = Sheets("sheet1")
With wks
Dim rng As Range
Set rng = .Range("R5")
Do Until IsEmpty(rng)
Sheets.Add.Name = rng.Value
Set rng = rng.Offset(0, 1)
Loop
End With
End Sub
Error handling should always be used when naming sheets from a list to handle
invalid characters in sheet names
sheet names that are too long
duplicate sheet names
Pls change Sheets("Title") to match the sheet name (or position) of your title sheet
The code below uses a variant array rather than a range for the sheet name for performance reasons, although turning off ScreenUpdating is likely to make the biggest difference to the user
Sub SheetAdd()
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim strError As String
Dim vArr()
Dim lngCnt As Long
Dim lngCalc As Long
Set ws1 = Sheets("Title")
vArr = ws1.Range(ws1.[r5], ws1.[r5].End(xltoRight))
If UBound(vArr) = Rows.Count - 5 Then
MsgBox "sheet range for titles appears to be empty"
Exit Sub
End If
With Application
.ScreenUpdating = False
.EnableEvents = False
lngCalc = .Calculation
End With
For lngCnt = 1 To UBound(vArr)
Set ws2 = Sheets.Add
On Error Resume Next
ws2.Name = vArr(lngCnt, 1)
If Err.Number <> 0 Then strError = strError & vArr(lngCnt, 1) & vbNewLine
On Error GoTo 0
Next lngCnt
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = lngCalc
End With
If Len(strError) > 0 Then MsgBox strError, vbCritical, "These potential sheet names were invalid"
End Sub
This is probably the simplest. No error-handling, just a one-time code to create sheets
Sub test()
Workbooks("Book1").Sheets("Sheet1").Range("A1").Activate
Do Until IsEmpty(ActiveCell)
Sheets.Add.Name = ActiveCell.Value
Workbooks("Book1").Sheets("Sheet1").Select
ActiveCell.Offset(0, 1).Select
Loop
End Sub