I am trying to parse through many different sheets and pick out specific data. I then need to place this data into specific columns and rows that depend on which column and row they are in the original sheet. In order to determine the row I need to create a range that contains the column all the way down to the current cell. I found code that explains how to do that (Select from ActiveCell to first cell in column. Data in column includes blanks), but when I run it, it throws the error message "Method "Range" not supported for Object "Worksheet"". I have already tried removing xSheet before the Range statement. Is there maybe something else wrong with my code? Thanks a lot for your help in advance!
Dim xSheet As Worksheet, DestSh As Worksheet
Dim Last As Long, crow As Long, ccol As Long
Dim copyRng As Range, destRng As Range, colSrc As Range, rowSrc As Range
Dim cRange As Range, copyTemp As Range, copyEnd As Range, copyStart As Range
Dim exchDest As Range, rowRange As Range
Dim numCol As Long, numRow As Long
Dim c As Range, q As Range
Dim uniqueVal() As Variant, x As Long
For Each xSheet In ActiveWorkbook.Worksheets
'Edit
Set copyStart = xSheet.Range("A1")
crow = xSheet.Cells(Rows.Count, 1).End(xlUp).Row
ccol = xSheet.Cells(1, Columns.Count).End(xlToRight).Column 'find a smarter way of doing this
Set copyEnd = xSheet.Cells(crow, ccol)
Set copyRng = xSheet.Range(copyStart, copyEnd)
If InStr(1, xSheet.Name, "ACCOUNT") And xSheet.Range("B1") <> "No Summary Available" Then _
For Each c In copyRng.SpecialCells(xlCellTypeVisible)
If IsNumeric(c) And Not c.Value = "0" Then _
Set rowRange = xSheet.Range(c.EntireColumn.Cells(1), c) 'problem line
For Each q In rowRange.SpecialCells(xlCellTypeVisible)
If InStr(1, q.Value, "C-") Then _
Set rowSrc = q
Next q
Set colSrc = c.EntireRow.Offset(0).Cells(1)
numCol = DestSh.Cells.Find(colSrc.Value, SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Column
numRow = DestSh.Cells.Find(rowSrc.Value, SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
'Set destination
Set destRng = DestSh.Cells(numRow, numCol)
'Copy to destination Range
c.Copy destRng
'If destRng.Column > 40 Then _
' Set destRng = destRng.Offset(1, -30)
End If
Next c
End If
Next xSheet
Related
Thank you in advance. New to VBA and trying to teach myself in my spare time. I am hoping someone can provide me some code to build on.
I want to loop through column K and search for each cell in columns A:I. Then I want to select the whole row and cut to another sheet. This is the code I have written, it utilized activecell but as you can imagine I would like to avoid having to click the cell I want to search for every time I execute the Macro. Especially, if I have 150 values in column K.
Sub Lineups()
Dim rng As Range
Set rng = Range("A2:I1501")
Dim ac As Range
Set ac = Application.ActiveCell
rng.Find(what:=ac).Select
ac.Interior.Color = 65535
Range("A" & ActiveCell.Row).Resize(1, 9).Cut
ActiveWindow.ScrollRow = 1
Sheets("Lineups").Select
NextRow = Cells(Rows.Count, 1).End(xlUp).Row + 1
Cells(NextRow, 1).Select
ActiveSheet.Paste
Sheets("Data").Select
End Sub
Picture of the Data Set is below.
Data Set
Please, try the next code. Not tested, but it should work. Selecting, activating is not ta good habit. It only consumes Excel resources without bringing any benefit. Then, coloring, copying each cell/range during iteration, takes time and makes code slower. The best way is to build Union ranges and color/copy at the end of the code, at once:
Sub Lineups()
Dim ws As Worksheet, rng As Range, ac As Range, rngCol As Range
Dim lastRow As Long, rngCopy As Range, arrRng, i As Long
Set ws = ActiveSheet 'use there the sheet you want processing (probably Sheets("Data")
'lastRow = ws.Range("K" & ws.rows.count).End(xlUp).row 'the last row in column K:K
lastRow = 1501 'if you need last cell in K:K, uncomment the line above and comment this one
Set rng = ws.Range("A2:H" & lastRow)
For i = 2 To lastRow
Set ac = rng.Find(what:=ws.Range("K" & i).value, After:=ws.Range("A2"), LookIn:=xlValues, Lookat:=xlWhole)
If Not ac Is Nothing Then 'if a match has been found:
If rngCol Is Nothing Then 'build the range with matching cells, to be colored at the end, at once:
Set rngCol = ws.Range("K" & i)
Else
Set rngCol = Union(rngCol, ws.Range("K" & i))
End If
If rngCopy Is Nothing Then 'build the range with matching cells, to be colored at the end, at once:
Set rngCopy = ws.Range("A" & ac.row, ws.cells(ac.row, "i"))
Else
Set rngCopy = Union(rngCopy, ws.Range("A" & ac.row, ws.cells(ac.row, "i")))
End If
End If
Next i
If Not rngCol Is Nothing Then rngCol.Interior.Color = 65535 ' color the interior of the matching cells in K:K
'Copy the necessary range in sheet "Lineups" and clear the copied range:
Dim wsL As Worksheet, nextRow As Long
Set wsL = Sheets("Lineups")
nextRow = wsL.cells(rows.count, 1).End(xlUp).row + 1
If Not rngCopy Is Nothing Then 'if at least a match has been found:
rngCopy.Copy wsL.cells(nextRow, 1) 'copy the union range at once
rngCopy.ClearContents 'clear contents of the union range at once
End If
End Sub
I am leaving now my office. If something does not work as you need, or you do not understand the code, do not hesitate to ask or specify what is happening against what you need. I will be able to reply after some hours when I will be at home.
Edited:
Please, test the next version and send some feedback:
Sub Lineups_()
Dim ws As Worksheet, rng As Range, rngSearch As Range, ac As Range, rngCol As Range
Dim lastRow As Long, rngCopy As Range, rngExcl As Range, i As Long, k As Long
Set ws = ActiveSheet 'use there the sheet you want processing (probably Sheets("Data")
lastRow = ws.Range("K" & ws.Rows.Count).End(xlUp).Row 'the last row in column K:K
ws.Range("K2:K" & lastRow).Interior.Color = xlNone 'clear interior color to see the changes (you can comment it, if not necessary)
Set rng = ws.Range("A2:H1501")
Set rngSearch = rng 'set a so named search range, adapted by excluding of processed rows
For i = 2 To lastRow
Set ac = rngSearch.Find(what:=ws.Range("K" & i).Value, After:=rngSearch.Cells(1, 1), LookIn:=xlValues, Lookat:=xlWhole)
If Not ac Is Nothing Then 'if a match has been found:
If rngCol Is Nothing Then 'build the range with matching cells, to be colored at the end, at once:
Set rngCol = ws.Range("K" & i)
Else
Set rngCol = Union(rngCol, ws.Range("K" & i))
End If
If rngCopy Is Nothing Then 'build the range with matching cells, to be colored at the end, at once:
Set rngCopy = ws.Range("A" & ac.Row, ws.Cells(ac.Row, "i")):
Set rngExcl = ws.Range("A" & ac.Row) 'set the range to be excluded
Else
Set rngCopy = Union(rngCopy, ws.Range("A" & ac.Row, ws.Cells(ac.Row, "i")))
Set rngExcl = Union(rngExcl, ws.Range("A" & ac.Row)) 'build the range to be excluded
End If
End If
'build the string where to search for:
Set rngSearch = InverseIntersect(rngSearch, rngExcl.EntireRow)
Next i
If Not rngCol Is Nothing Then rngCol.Interior.Color = 65535 ' color the interior of the matching cells in K:K
'Copy the necessary range in sheet "Lineups" and clear the copied range:
Dim wsL As Worksheet, nextRow As Long
Set wsL = ws.Next ' Sheets("Lineups")
nextRow = wsL.Cells(Rows.Count, 1).End(xlUp).Row + 1
If Not rngCopy Is Nothing Then 'if at least a match has been found:
rngCopy.Copy wsL.Cells(nextRow, 1) 'copy the union range at once
rngCopy.ClearContents 'clear contents of the union range at once
End If
MsgBox "Ready..."
End Sub
Function InverseIntersect(bigRng As Range, rngExtract As Range) As Range
Dim rng As Range, rngRow As Range
For Each rngRow In bigRng.rows 'iterate between the range to be processed rows:
If Intersect(rngRow, rngExtract) Is Nothing Then 'if iterated row intersects with range to be extracted:
'creates a range only from rows which do not intersect
If rng Is Nothing Then 'Set the range as the current row
Set rng = rngRow
Else
Set rng = Union(rng, rngRow) 'creates a Union between the previous existing range and the current row
End If
End If
Next
Set InverseIntersect = rng 'set the function as the newly created range
End Function
I am looking for some assistance... Below is a code and some images of what I am attempting to acheive. I have created a selector which when you enter a qty. I want it to take the line with the quantity included and take it to another sheet on the next available line. My code is not yielding an error but neither is it doing anything at all.
I wish to take range J:P of the line with a qty entered and then paste it into the other worksheet in the next blank row of column D as there will be entries already included in A-C. Can anyone here help?
Sub Add()
Dim searchRange As Range
Dim foundCell As Range
Dim mysearch As Integer
Dim iRow As Long
Dim ws1, ws2 As Worksheet
Set ws1 = Worksheets("Output")
Set ws2 = Worksheets("Selector")
iRow = Sheets("Output").Range("D2").End(xlUp) + 1
mysearch = Sheets("Selector").Range("N10").Value
With Sheets("Selector")
Set searchRange = Sheets("Selector").Range("N12:N35") ', .Range("A" & .Rows.Count).End(xlUp))
End With
Set foundCell = searchRange.Find(what:=mysearch, Lookat:=xlWhole, MatchCase:=False, SearchFormat:=False)
If Not foundCell Is Nothing Then
ws1.Cells(iRow, 4).Value = foundCell.Offset(0, -4).Value
'and so on
End If
End Sub
This is the selector
This is where I would like to paste the values (in a different order).
Try the following, I've simply amended your code slightly, and I believe it should work as expected:
Sub Add()
Dim foundCell As Range
Dim mysearch As Integer
Dim iRow As Long, Last As Long
Dim ws1 As Worksheet, ws2 As Worksheet
Set ws1 = Worksheets("Output")
Set ws2 = Worksheets("Selector")
iRow = ws1.Cells(ws1.Rows.Count, "D").End(xlUp).Row + 1
Last = ws2.Cells(ws2.Rows.Count, "N").End(xlUp).Row
mysearch = ws2.Range("N10").Value
Set foundCell = ws2.Range("N12:N" & Last).Find(what:=mysearch, Lookat:=xlWhole)
If Not foundCell Is Nothing Then
ws1.Cells(iRow, 4).Value = foundCell.Offset(0, -4).Value
End If
End Sub
I'm trying to use VBA to find the Sheet1 column header “Country”, and copy it along with the 20 columns to the right of it, to to Sheet2 column A
I have tried:
Dim lr As Long, lc As Long, Col as Long
With ThisWorkbook.Worksheets("Sheet1")
Col = Application.Match("Country", Sheets("Sheet1").Rows(1), 0)
lr = .Cells(Rows.Count, 1).End(xlUp).Row
lc = .Cells(1, Columns.Count).End(xlToRight).Column
With .Cells (lr, 20).Copy Destination:= Sheets("Sheet2"). Column (“A:A”)
End With
End With
Here's your code, refactored and pointing out the issues in comments
Sub Demo()
Dim lr As Long
'lc not used, left out
Dim Col As Variant 'allow for possibility Country is not found
With ThisWorkbook.Worksheets("Sheet1")
' Use the with block
' Sheets("Sheet1") may or may not be the same sheet as ThisWorkbook.Worksheets("Sheet1")
'Col = Application.Match("Country", Sheets("Sheet1").Rows(1), 0)
Col = Application.Match("Country", .Rows(1), 0)
' Allow for possibility Country is not found
If Not IsError(Col) Then
' Rows.Count refers to the ActiveSheet,
' which may or may not have the same number of rows as ThisWorkbook.Worksheets("Sheet1")
' You are also assuming that Column A has at least the number of rows as your data.
' Is this what you want?
'lr = .Cells(Rows.Count, 1).End(xlUp).Row
lr = .Cells(.Rows.Count, 1).End(xlUp).Row
' Specify the source range, starting at row 1, column containing Country
' then resize to the required size: lr rows, 21 columns
' Specify destination as top left cell, on the fully qualified sheet
.Cells(1, Col).Resize(lr, 21).Copy Destination:=ThisWorkbook.Worksheets("Sheet2").Cells(1, 1)
' Alternative, if you don't need to copy formatting.
'Dim r As Range
'Set r = .Cells(1, Col).Resize(lr, 21)
'ThisWorkbook.Worksheets("Sheet2").Cells(1, 1).Resize(r.Rows.Count, r.Columns.Count).Value _
' = r.Value
End If
End With
End Sub
Find header with text "Country" (I'm assuming your header is in Row 1)
Once found, Copy the "Country" column and 19 columns to right
Paste in Sheet2 A1
Sub ColumnHunt()
Dim ws As Worksheet: Set ws = ThisWorkbook.Sheets("Sheet1")
Dim pr As Range: Set pr = ThisWorkbook.Sheets("Sheet2").Range("A1") 'pr = Paste Range
Dim lr As Long, Found As Range
lr = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
Set Found = ws.Cells(1, 1).EntireRow.Find("Country")
If Not Found Is Nothing Then
ws.Range(ws.Cells(1, Found.Column), ws.Cells(lr, Found.Column + 20)).Copy pr
Else
MsgBox "Country Column Not Found", vbCritical
End If
End Sub
I hope my following code (with some comments) will help
Option Explicit
Private Sub CommandButton1_Click()
' Get the last Row Number of your Data
Dim myLastRow As Integer
myLastRow = Sheet1.Cells(Sheet1.Rows.Count, "A").End(xlUp).Row
' Get the Column Number of your Header Name = "Country"
Dim myHeaderString As String
Dim myHeaderCell As Range
myHeaderString = "Country"
Set myHeaderCell = Sheet1.Rows(1).Find(What:=myHeaderString, LookIn:=xlValues, _
LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
' Be sure that we find that column, send an error message if NOT
If Not myHeaderCell Is Nothing Then
' Get your Source Data Range
Dim myColumnNo As Integer
myColumnNo = myHeaderCell.Column
Dim myRange As Range
Set myRange = Sheet1.Range(Sheet1.Cells(1, myColumnNo), Sheet1.Cells(myLastRow, myColumnNo + 20))
' Copy The Source Data Range
Sheet1.Activate
myRange.Copy
' Past to the Target location
Sheet2.Activate
Sheet2.Cells(1, 1).Select
Sheet2.Paste
Else
MsgBox "No Column Header found"
End If
End Sub
Below is the code I wrote, which deletes the rows that contain the value "PRODUCTION" in column M
Sub DeleteProducts()
Dim LR, i As Long
Dim RNG As Range
Dim ws As Worksheet
For Each ws In ActiveWorkbook.Sheets
LR = ws.Cells(Rows.Count, "M").End(xlUp).Row
For i = LR To 2 Step -1
Select
Case ws.Cells(i, "M").Value
Case Is <> "Production"
ws.Cells(i, "M").EntireRow.Delete shift:=xlUp
End Select
Next i
Next ws
End Sub
I need rows to be deleted in multiple sheets according to the column header because column name may change (M to something else) but the header will be the same in every sheet.
I assume that the header of the column is in the first row of each worksheet:
Sub DeleteProducts()
Dim LR as Long, LC as Long, i As Long, j As Long
Dim RNG As Range
Dim ws As Worksheet
For Each ws In ActiveWorkbook.Sheets
LC = ws.Cells(1, Columns.Count).End(xlToRight).Column
For i = LC To 2 Step -1
If ws.Cells(1, i) = "YOURnameHERE" Then
LR = ws.Cells(Rows.Count, i).End(xlUp).Row
Exit For
End If
Next
For j = LR To 2 Step -1
If ws.Cells(j, i).Value <> "Production" Then ws.Cells(j, i).EntireRow.Delete shift:=xlUp
Next
Next ws
End Sub
This will find the name of the column, and then store in i that column's number. With that information you can then find the last row of that very column, and look for every value that is not = "Production".
I also corrected some other bits of code, just for it to be cleaner.
Her is my shot at the task. The code searches for the desired header in the first row on all sheets. If the header is found, the search for "Production" continues in the column in witch the header was found.
EDIT: Did some minor cleanup of the code.
Sub DeleteRowProduction()
Dim Header As Range
Dim FoundCell As Range
Dim ws As Worksheet
Dim HeaderToFind As String
Dim ValueToFind As String
HeaderToFind = "aaa"
ValueToFind = "Production"
For Each ws In Worksheets
Set Header = ws.Rows(1).Find(what:=HeaderToFind, LookIn:=xlValues, lookat:=xlWhole, MatchCase:=True)
If Not Header Is Nothing Then
Set FoundCell = ws.Columns(Header.Column).Find(what:=ValueToFind, LookIn:=xlValues, lookat:=xlWhole, MatchCase:=True)
Do While Not FoundCell Is Nothing
ws.Rows(FoundCell.Row).Delete
Set FoundCell = Nothing
Set FoundCell = ws.Columns(Header.Column).Find(what:=ValueToFind, LookIn:=xlValues, lookat:=xlWhole, MatchCase:=True)
Loop
End If
Next ws
End Sub
Please use Range.Find to find the target column. Modified your code below.
Sub DeleteProducts()
Dim LR, i As Long
Dim RNG As Range
Dim ws As Worksheet
Dim rngTargetColumn as range
For Each ws In ActiveWorkbook.Sheets
Set rngTargetColumn = ws.Range("1:1").Find("*<Column Heading>*") 'Replace <Column Heading> with your column header string
if not rngTargetColumn is Nothing then
LR = ws.Cells(Rows.Count, rngTargetColumn.Column).End(xlUp).Row
For i = LR To 2 Step -1
If ws.Cells(i, rngTargetColumn.Column).Value <> "Production" Then
ws.Cells(i, rngTargetColumn.Column).EntireRow.Delete shift:=xlUp
End If
Next i
Set rngTargetColumn = Nothing
End If
Next ws
End Sub
I'm relatively new to VBA, I have only some experience with Python and only very little experience looking at other VBA macros and adjusting them to my need, so I'm trying to do what I can.
What I am trying to do is for each part number pasted in worksheet B (worksheet B, row A) I want to find the same part number from a different worksheet containing all part numbers (worksheet D, row A) and copy the description (worksheet D, row H) from worksheet D to another column, (worksheet B, row D) then check the next part number in the row and repeat.
The current error that I'm getting is that there is "Compile error: Else without if", I'm sorry that I am not very proficient, but any help would be greatly appreciated.
Other information:
-My part numbers to search through in worksheet B, column B are filled in from worksheet A, is it okay to just make it =A!B2 or =CONCATENATE(A!B2)?
Sub Description()
Dim wsA As Worksheet, wsB As Worksheet, wsC As Worksheet, wsD As Worksheet
Dim Rng As Range
Set wsB = Worksheets("B")
Set wsD = Worksheets("D")
Do: aRow = 2
If wsB.Cells(aRow, 2) <> "" Then
With Worksheets("D").Range("A:A")
x = wsB.Cells(aRow, 2)
Set Rng = .Find(What:=x, _
After:=.Cells(.Cells.Count), _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False)
Selection.Copy
wsB.Cells(dRow, 2).Paste
dRow = dRow + 1
Else
aRow = aRow + 1
Loop Until wsB.Cells(aRow, 2) = ""
End Sub
Thanks again!
Edit: Can't Execute code in break mode is current error
Sub Description()
Dim wsA As Worksheet, wsB As Worksheet, wsC As Worksheet, wsD As Worksheet
Dim Rng As Range
Set wsB = Worksheets("B")
Set wsD = Worksheets("D")
aRow = 2
dRow = 2
Do:
If wsB.Cells(aRow, 1) <> "" Then
With Worksheets("D").Range("A:A")
Set Rng = .Find(What:=wsB.Cells(aRow, 1), _
After:=.Cells(.Cells.Count), _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False)
Rng.Copy
Rng.Offset(0, 3).Paste (Cells(aRow, 4))
dRow = dRow + 1
aRow = aRow + 1
End With
End If
Loop Until wsB.Cells(aRow, 1) = ""
End Sub
Can you try to put End If on the next line after aRow = aRow + 1. See MSDN for syntax msdn.microsoft.com/en-us/library/752y8abs.aspx
In Excel we usually call vertical range as column, and horizontal one as row.
From your code and question description, I assume what you said "row A" is column A.
Also, your code scan through wsB.Cells(aRow, 2). It is column B not column A.
Anyway, this is just a minor problem.
The following code will check cells of column B of worksheet B. If the same value is found
in column A of worksheet D, then the cooresponding cell in column H of worksheet D will
be copied to the cell in column B of worksheet B.
Option Explicit
Sub Description()
Dim wsB As Worksheet, wsD As Worksheet, aRow As Long
Dim rngSearchRange As Range, rngFound As Range
Set wsB = Worksheets("B")
Set wsD = Worksheets("D")
Set rngSearchRange = wsD.Range("A:A")
aRow = 2
Do While wsB.Cells(aRow, 2).Value <> ""
Set rngFound = rngSearchRange.Find(What:=wsB.Cells(aRow, 2).Value, LookAt:=xlWhole)
If Not rngFound Is Nothing Then
wsD.Cells(rngFound.Row, 8).Copy Destination:=wsB.Cells(aRow, 4) ' Indexes of Column H, D are respectively 8, 4
End If
aRow = aRow + 1
Loop
End Sub
Here's what worked for me.
Sub Description()
Application.ScreenUpdating = False
Dim LastRow As Long
LastRow = Sheets("B").Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
Dim rng As Range
Dim foundRng As Range
For Each rng In Sheets("B").Range("B2:B" & LastRow)
Set foundRng = Sheets("D").Range("A:A").Find(rng, LookIn:=xlValues, lookat:=xlWhole)
If Not foundRng Is Nothing Then
Sheets("B").Cells(rng.Row, "D") = Sheets("D").Cells(foundRng.Row, "H")
End If
Next rng
Application.ScreenUpdating = True
End Sub