I have a data connection to an internal website that grabs a full webpage and imports it to the "DC" sheet. From there it's moved to "staging" via an advanced filter macro using the below code. The N1100 is not the last row with text, it was a arbitrary number a fair distance past the end of my data.
Private Sub Worksheet_Change(ByVal Target As Range)
Call Password_Unprotect
Dim ws As Worksheet
Set ws = ThisWorkbook.Sheets("DC")
Dim lrng As Range
Set lrng = ThisWorkbook.Sheets("DC").Range("A158:N1100")
Dim crng As Range
Set crng = ThisWorkbook.Sheets("DC").Range("A158:N1100")
Dim copyto As Range
Set copyto = ThisWorkbook.Sheets("Staging").Range("A1:H1")
lrng.AdvancedFilter xlFilterCopy, crng, copyto, Unique:=False
'Call password_protect
End Sub
My problem is that whenever the the webpage I use for my data connection changes it breaks my advanced filter since the row my criteria starts on shifts. I'm looking to either make the advanced filter smart enough to find the line it needs to start on or delete every line above it then move the data over to the "staging" sheet. A point of note, the cell containing "Division" is unique on the sheet. The highlighted line is the start of the advanced filter.
I've uploaded a snit-it of my worksheet.
The below code should get you what you looking for. Just need to run through Column A to look for the DEVICE text and then use that as start and then do a .End(xlUp) on Column A for the last Row.
Another note, always remember to use Option Explicit on on all your sheet to ensure you always declaring your variables.
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Call Password_Unprotect
Dim DCSheet As Worksheet
Dim lrng As Range
Dim crng As Range
Dim copyto As Range
Dim StartRow As Long
Dim ColACell As Range
Dim LastRow As Long
Set DCSheet = ThisWorkbook.Sheets("DC")
LastRow = DCSheet.Cells(DCSheet.Rows.Count, "A").End(xlUp).Row
'Stopping at 300 will just save time if the text is not found
'if it is possible that the start row could be further down then increase the number
For Each ColACell In DCSheet.Range("A1:A300").Cells
If ColACell.Text = "DEVICE" Then
'Can have cross check for the IP text in Column B
If ColACell.Offset(0, 1).Text = "IP" Then StartRow = ColACell.Row
End If
Next ColACell
Set lrng = DCSheet.Range("A" & StartRow & ":N" & LastRow)
Set crng = DCSheet.Range("A" & StartRow & ":N" & LastRow)
Set copyto = ThisWorkbook.Sheets("Staging").Range("A1:H1")
lrng.AdvancedFilter xlFilterCopy, crng, copyto, Unique:=False
'Call password_protect
End Sub
Related
I have an Excel document with two different Sheets. Sheet 2 has columns header names and rows header names. Sheet 1 has some of these columns with exact header names and rows header names but it's filled with data.
enter image description here, enter image description here
I want to make a macro that will look through all the column/rows headers in Sheet 1 and find their corresponding match in Sheet2. When the match is found, I need to copy the entry of the Sheet column/row header into the matching header of sheet2. Some entries in Sheet2 will not have matches and will remain blank.
I want it to look like this:
enter image description here
This is my code so far, it is working for the column headers but I don't know how to add for row headers as well. Any help is welcomed :)
Sub CopyData()
Application.ScreenUpdating = False
Dim LastRow As Long, header As Range, foundHeader As Range, lCol As Long, srcWS As Worksheet, desWS As Worksheet
Set srcWS = Sheets("Sheet1")
Set desWS = Sheets("Sheet2")
LastRow = srcWS.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
lCol = desWS.Cells(3, Columns.Count).End(xlToLeft).Column
For Each header In desWS.Range(desWS.Cells(3, 2), desWS.Cells(3, lCol))
Set foundHeader = srcWS.Rows(2).Find(header, LookIn:=xlValues, lookat:=xlWhole)
If Not foundHeader Is Nothing Then
srcWS.Range(srcWS.Cells(3, foundHeader.Column), srcWS.Cells(LastRow, foundHeader.Column)).Copy desWS.Cells(4, header.Column)
End If
Next header
Application.ScreenUpdating = True
End Sub
You can use built-in Range.Consolidate method (https://learn.microsoft.com/en-us/office/vba/api/excel.range.consolidate):
(Edit2)
Option Explicit
Sub ConsolidateThis()
Dim rng1 As Range, rng2 As Range, addr As String
With ThisWorkbook
' determine source and destination ranges
Set rng1 = getTableRange(.Worksheets("Sheet1").Range("A2"))
Set rng2 = getTableRange(.Worksheets("Sheet2").Range("A3"))
' make full address of consolidated range like "'[Consolidate.xlsm]Sheet1'!R3C1:R6C5"
addr = "'[" & .Name & "]" & rng1.Parent.Name & "'!" & rng1.Address(ReferenceStyle:=xlR1C1)
' do consolidation
rng2.Consolidate Sources:=Array(addr), Function:=xlSum, TopRow:=True, LeftColumn:=True
End With
End Sub
' Returns the range that starts with the top left corner cell and is bounded
' on the right and bottom by empty cells
Function getTableRange(LeftTopCornerCell As Range) As Range
Dim ws As Worksheet, rightEdge As Long, downEdge As Long
With LeftTopCornerCell(1)
Set ws = .Parent
rightEdge = ws.Cells(.Row, ws.Columns.Count).End(xlToLeft).Column
downEdge = ws.Cells(ws.Rows.Count, .Column).End(xlUp).Row
End With
Set getTableRange = ws.Range(LeftTopCornerCell(1), ws.Cells(downEdge, rightEdge))
End Function
Your best solution might to set 2 ranges, each taking values from tables in Sheet1 and Sheet2. Let's call them rgSrcTable and rgDestTable. Then you need to loop using For Each through each range and compare top and left headers, and when you find a match, copy the value of the cell in rgSrcTable to the cell in rgDestTable.
Edit: Code sample. Feel free to adapt ranges to your needs. Since this routine used Range.Value property, you can filter any data (string, numbers, etc.)
Option Explicit
Sub CopyDataWithFilter()
Dim iRowHeader As Integer, iColHeader As Integer
Dim rngSrc As Range, rngDest As Range, celSrc As Range, celDest As Range
iRowHeader = 2
iColHeader = 1
With ThisWorkbook
' Set source and destination ranges. Modify ranges according to your needs
Set rngSrc = .Worksheets("shtSrc").Range("$B$3:$E$5")
Set rngDest = .Worksheets("shtDest").Range("$B$3:$E$5")
' Loop through source range and dest range
For Each celDest In rngDest
For Each celSrc In rngSrc
' Compare top headers and left headers respectively. If matching, copy the value in destination table.
If .Worksheets("shtSrc").Cells(celSrc.Row, iColHeader).Value = .Worksheets("shtDest").Cells(celDest.Row, iColHeader).Value And _
.Worksheets("shtSrc").Cells(iRowHeader, celSrc.Column).Value = .Worksheets("shtDest").Cells(iRowHeader, celDest.Column).Value Then
celDest.Value = celSrc.Value
End If
Next celSrc
Next celDest
End With
End Sub
Result:
I am trying to use the offset function and cannot figure out the problem with my synatx.
I copied this code from another question about offset on this website.
I want to look for a string in column X (starting at X9 always) and if present, I want to know the value of the cell that is two columns over and in the same row.
I would like to use the offset value in an additional part of the same code, so it needs to be named as a variable, but I decided to see if I could first get VBA to at least read the information I want, hence the message box.
Here is the code:
Private Sub CommandButton3_Click()
Dim LeftStrike As Range
Dim FrameLeftStrike As Range
Dim lastRow As Long
lastRow = Range("X" & Rows.Count).End(xlUp).Row
Set LeftStrike = Range("X9:X" & lastRow)
Set FrameLeftStrike = Range("LeftStrike").Offset(0, 4).Value
For Each FrameLeftStrike In LeftStrike
If InStr(1, LeftStrike.Value, "Foot Strike") > 0 Then
MsgBox FrameLeftStrike
End If
Next FrameLeftStrike
End Sub
The variable "FrameLeftStrike" is the problem.
I receive:
application defined or object defined error.
I tried different iterations.
If I change the line of code to,
Set FrameLeftStrike = Sheet4.Range("LeftStrike").Offset(0, 4).Value
I get the same error.
If I change it to
Set FrameLeftStrike = LeftStrike.Offset(0, 4).Value
I get
run-time error '424' Object required.
I want to use this code in the active sheet only, but the name of the active sheet will change as it will get copied as a template for other projects.
Loop through each cell (my_cell) in Column X (my_range)
Individually check if the cell contains Foot Strike
If so, return the value 2 cells to right in a MsgBox
Sub test()
Dim ws As Worksheet: Set ws = ThisWorkbook.Sheets("Sheet1") '<-- Update
Dim my_range As Range, my_cell As Range
Dim lr As Long
lr = ws.Range("X" & ws.Rows.Count).End(xlUp).Row
Set my_range = ws.Range("X9:X" & lr)
For Each my_cell In my_range
If InStr(my_cell, "Foot Strike") Then
MsgBox my_cell.Offset(0, 2)
End If
Next my_cell
End Sub
I'm trying to fill blank cells in a certain region with 0. The reagion should be defined in the current workbook but in sheet2 (not the current sheet). Also the place where it is supposed to fill is between columns
BU:CQ in the current region (not all 100 000 000 lines). Just the number of lines that define the table between columns BU and CQ. I know the problem lies in defining the region... See the code below.
What is missing?
Sub FillEmptyBlankCellWithValue()
Dim cell As Range
Dim InputValue As String
On Error Resume Next
InputValue = "0"
For Each cell In ThisWorkbook.Sheets("Sheet2").Range(BU).CurrentRegion
'.Cells(Rows.Count, 2).End(xlUp).Row
If IsEmpty(cell) Then
cell.Value = InputValue
End If
Next
End Sub
I've this code that i'm positive that works! But i don't wnat selection! I want somthing that specifies the sheet and a fixed range.
Now my idea is to replace "selection" with the desired range. - In this case in particular the range should be 1 - between BU:CQ; 2 - starting at row 2; 3 - working the way down until last row (not empty = end of the table that goes from column A to DE)
Sub FillEmptyBlankCellWithValue()
Dim cell As Range
Dim InputValue As String
On Error Resume Next
For Each cell In Selection
If IsEmpty(cell) Then
cell.Value = "0"
End If
Next
End Sub'
PS: And I also need to specify the sheet, since the button that will execute the code will be in the same workbook but not in the same sheet.
Use SpecialsCells:
On Error Resume Next 'for the case the range would be all filled
With ws
Intersect(.UsedRange, .Range("BU:CQ")).SpecialCells(xlCellTypeBlanks).Value = 0
End With
On Error GoTo 0
MUCH faster than looping !
Try using cells() references, such as:
For i = cells(1,"BU").Column to cells(1,"CQ").Column
cells(1,i).value = "Moo"
Next i
In your current code you list Range(BU) which is not appropriate syntax. Note that Range() can be used for named ranges, e.g., Range("TheseCells"), but the actual cell references are written as Range("A1"), etc. For Cell(), you would use Cells(row,col).
Edit1
With if statement, with second loop:
Dim i as long, j as long, lr as long
lr = cells(rows.count,1).end(xlup).row
For i = 2 to lr 'assumes headers in row 1
For j = cells(1,"BU").Column to cells(1,"CQ").Column
If cells(i,j).value = "" then cells(i,j).value = "Moo"
Next j
Next i
First off, you should reference the worksheet you're working with using:
Set ws = Excel.Application.ThisWorkbook.Worksheets(MyWorksheetName)
Otherwise VBA is going to choose the worksheet for you, and it may or may not be the worksheet you want to work with.
And then use it to specify ranges on specific worksheets such as ws.Range or ws.Cells. This is a much better method for specifying which worksheet you're working on.
Now for your question:
I would reference the range using the following syntax:
Dim MyRange As Range
Set MyRange = ws.Range("BU:CQ")
I would iterate through the range like so:
Edit: I tested this and it works. Obviously you will want to change the range and worksheet reference; I assume you're competent enough to do this yourself. I didn't make a variable for my worksheet because another way to reference a worksheet is to use the worksheet's (Name) property in the property window, which you can set to whatever you want; this is a free, global variable.
Where I defined testWS in the properties window:
Public Sub test()
Dim MyRange As Range
Dim tblHeight As Long
Dim tblLength As Long
Dim offsetLen As Long
Dim i As Long
Dim j As Long
With testWS
'set this this to your "BU:CQ" range
Set MyRange = .Range("P:W")
'set this to "A:BU" to get the offset from A to BU
offsetLen = .Range("A:P").Columns.Count - 1
'set this to your "A" range
tblHeight = .Range("P" & .Rows.Count).End(xlUp).Row
tblLength = MyRange.Columns.Count
End With
'iterate through the number of rows
For i = 1 To tblHeight
'iterate through the number of columns
For j = 1 To tblLength
If IsEmpty(testWS.Cells(i, offsetLen + j).Value) Then
testWS.Cells(i, offsetLen + j).Value = 0
End If
Next
Next
End Sub
Before:
After (I stopped it early, so it didn't go through all the rows in the file):
If there's a better way to do this, then let me know.
I have an excel sheet that has three columns: employee number employee name availability What I am trying to do is when the availability value changes from a number to nothing the employee number and the employee name associated with that row gets a strikethrough. Also when an availability number is added the strikethrough disappears. I have written some code below but I have no idea if I am going in the right direction.
Sub change(ByVal Target As Range)
Dim ws As Worksheet
Dim watchrange As Range
dim intersectrange as range
Set ws = Worksheets("Workbench Report")
endrow = ws.Cells(ws.Rows.count, "E").End(xlUp).Row
Set watchrange = Range("E2:E" & endrow)
Set intersectrange = Intersect(Target, watchrange)
If intersectrange = "" Then
ws.Range("B" & rng.Row).Resize(1, 2).Font.Strikethrough = True
Else
'do nothing
End If
End Sub
Could someone help me?
Thank you in advance
With data like:
This worksheet event macro:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim watchrange As Range, r As Range, rw As Long
Dim intersectrange As Range, endrow As Long
endrow = Cells(Rows.Count, "A").End(xlUp).Row
Set watchrange = Range("C2:C" & endrow)
Set intersectrange = Intersect(Target, watchrange)
If intersectrange Is Nothing Then Exit Sub
For Each r In intersectrange
rw = r.Row
If r.Value = "" Then
Range("A" & rw & ":B" & rw).Font.Strikethrough = True
Else
Range("A" & rw & ":B" & rw).Font.Strikethrough = False
End If
Next r
End Sub
will meet your needs. You need to adjust the columns to match your data schema.
Because it is worksheet code, it is very easy to install and automatic to use:
right-click the tab name near the bottom of the Excel window
select View Code - this brings up a VBE window
paste the stuff in and close the VBE window
If you have any concerns, first try it on a trial worksheet.
If you save the workbook, the macro will be saved with it.
If you are using a version of Excel later then 2003, you must save
the file as .xlsm rather than .xlsx
To remove the macro:
bring up the VBE windows as above
clear the code out
close the VBE window
To learn more about Event Macros (worksheet code), see:
http://www.mvps.org/dmcritchie/excel/event.htm
EDIT#1:
This code is triggered by changes to column C and reside in the worksheet code area for that sheet.
If your button code changes those column C values, then this event code would work with it.
I have a list of names in Column A in a worksheet named "Email"
I want to populate a userform ListBox with the names Column A. However, I can't specify a fixed range as this list will grown and shrink. So how do I get the userform to populate the list with the correct number of items?
This is what I am currently trying but is not working (I'm sure it will be obvious to some people on here as to why not), I also saw another example using a simple For loop but I am unable to find the example again to show you.
Private Sub UserForm_Initialize()
Dim rngName As Range
Dim rng1 As Range
Dim rng2 As Range
Dim ws As Worksheet
Set ws = Worksheets("Email")
Set rngName = ws.Range("A:A").Find(What:="*", LookAt:=xlWhole, MatchCase:=False, SearchOrder:=xlByRows, SearchDirection:=xlPrevious)
Set rng1 = ws.Range("A1")
On Error GoTo ErrorHandle
Me.lbUsed.List = Range(rng1 & ":" & rngName).Value
ErrorHandle:
End Sub
EDIT:
I now have the following code but it is failing to work when I load the userform:
Private Sub UserForm_Initialize()
Dim rngName As Range
Dim rng1 As Range
Set rngName = Worksheets("Email").Range("A:A").Cells.Find(What:="*", LookAt:=xlWhole, MatchCase:=False, SearchOrder:=xlByRows, SearchDirection:=xlPrevious)
Set rng1 = Worksheets("Email").Range("A1:" & rngName.Address)
Me.lbUsed.List = Worksheets("Email").Range(rng1).Value
End Sub
Can anyone point me in the correct direction?
If you want to populate your listbox with all of the items in column A (assuming that these are in a continuous range), you could do this simply by modifying you code like this:
Private Sub UserForm_Initialize()
Dim rngName As Range
Dim ws As Worksheet
Dim i As Integer
Set ws = Worksheets("Email")
For i = 1 To ws.Cells(ws.Rows.Count, 1).End(xlUp).Row Step 1
If ws.Cells(i, 1).Value <> vbNullString Then Me.lbUsed.AddItem ws.Cells(i, 1).Value
Next i
End Sub
Point the RowSource property of the ListBox to dynamic Named Range in your spreadsheet. As you add or remove items to the range, the list will automatically pull in new items to the listbox. There's no need to write any code implement this requirement.
This is an old question, but I feel this second comment is good. I would like to add a little to it to help people achieve the described answer:
Create (ctrl + t) a table and open Formulas>Name Manager
Select doublec-click the table in the list of names and name it
In your userform, enter the name of the table (that you named it in 2.) in RowSource:
When you open the form you should see all the items in the table listed in the listbox:
If you add to the table you add to that listbox's list,
Here's a little code example to remove an item and reset the table size to fit:
Sub ChangeTableSize()
Dim n As Long
Dim Tbl As ListObject
Set Tbl = Sheets(8).ListObjects(9)
With Tbl
n = .DataBodyRange.Rows.Count
.DataBodyRange(20, 1).ClearContents
.Resize Range(Tbl.DataBodyRange.Resize(n, 1).Offset(-1, 0).Address)
End With
End Sub
and Here's one to add to the table:
Sub AddtoTable()
Dim n As Long
Dim Tbl As ListObject
Set Tbl = Sheets(8).ListObjects(9)
With Tbl
n = .DataBodyRange.Rows.Count
Tbl.DataBodyRange(n + 1, 1) = "New"
End With
End Sub
Hope it is found to be useful!