This question already has answers here:
Excel VBA, getting range from an inactive sheet
(3 answers)
Why does Range work, but not Cells?
(1 answer)
Closed 4 months ago.
I have problem with the worksheet/range initiating and I can't see why my code doesn't work. I was debugging and it seems like I had to be on a certain worksheet to make the related references to work. Can anyone please let me know what did I do wrong?
Sub salesImport()
Application.ScreenUpdating = False
'Excel workbook, the source and target worksheets, and the source and target ranges.
Dim wbBook As Workbook
Dim wsSource As Worksheet
Dim wsTarget As Worksheet
Dim rnSource As Range
Dim rnTarget As Range
Dim rng As Range
Dim cIndex, rIndex1, rIndex2, rIndex3, iR, iC As Integer
Dim rowC, columnC As Integer
'Initialize the Excel objects
Set wbBook = ThisWorkbook
With wbBook
Set wsSource = .Worksheets("Sales")
Set wsTarget = .Worksheets("Summary-Official")
End With
'On the source worksheet, set the range to the data stored
With wsSource
rowC = .Cells.SpecialCells(xlCellTypeLastCell).row
columnC = .Range("A1").SpecialCells(xlCellTypeLastCell).Column
Set rnSource = .Range(Cells(1, 1), Cells(rowC, columnC))
End With
With wsTarget
Set rnTarget = .Range("B98:AM122")
End With
rIndex1 = 6 'month
rIndex2 = 10 'plant
rIndex3 = 17 'sales
iR = 0
iC = 0
For Each Column In rnSource
Column.Cells(rIndex1, 1).Select
Dim m As String: m = Column.Cells(rIndex1, 1).Value
Select Case Month(DateValue("01 " & m & " 2012"))
Case 1
iC = 6
Case 2
iC = 7
Case 3
iC = 8
Case 4
iC = 9
End Select
iR = findrow2(Column.Cells(rIndex2, 1), rnTarget)
If iR <> 0 Then
rnTarget.Cells(iR - 97, iC).Value = Column.Cells(rIndex3, 1).Value
End If
'MsgBox ("got here")
Next Column
Application.ScreenUpdating = True
End Sub
Thanks!
With wsSource
'...
Set rnSource = .Range(Cells(1, 1), Cells(rowC, columnC))
End With
should be
With wsSource
'...
Set rnSource = .Range(.Cells(1, 1), .Cells(rowC, columnC))
End With
...otherwise your Cells() calls default to the activesheet, which may not be wsSource
Related
I'm looking to create a table without selecting the first row and creating a table. Then naming the table based on what the sheet name is.
Sub ConvertDataToTables()
' For i = 3 To 5
' Sheets(i).Activate
' Rows(1).EntireRow.Delete
' Next i
For i = 3 To 5
On Error Resume Next
Sheets(i).Select
ActiveSheet.ShowAllData
Cells.AutoFilter
Range("A2").CurrentRegion.Select
If ActiveSheet.ListObjects.Count < 1 Then
ActiveSheet.ListObjects.Add.Name = ActiveSheet.Name
End If
Next i
Table names get place with an underscore with a space and I don't want that. so Sum Day = Sum_Day from my code. I also want to have the selection not choose the top row but everything below.
Convert Table to Excel Table (ListObject)
Option Explicit
Sub ConvertDataToTables()
Const FIRST_CELL As String = "A2"
Const FIRST_INDEX As Long = 3
Const LAST_INDEX As Long = 5
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Dim ws As Worksheet, rg As Range, fCell As Range, lo As ListObject
Dim i As Long, NewName As String
For i = FIRST_INDEX To LAST_INDEX
Set ws = wb.Worksheets(i)
If ws.ListObjects.Count = 0 Then
' Remove the auto filter.
If ws.AutoFilterMode Then ws.AutoFilterMode = False
NewName = Replace(Application.Proper(ws.Name), " ", "")
ws.Name = NewName
Set fCell = ws.Range(FIRST_CELL)
With fCell.CurrentRegion
Set rg = fCell.Resize(.Row + .Rows.Count - fCell.Row, _
.Column + .Columns.Count - fCell.Column)
End With
Set lo = ws.ListObjects.Add(xlSrcRange, rg, , xlYes)
lo.Name = NewName
End If
Next i
End Sub
Try the following code. It will replace spaces from the sheet names. Also, it doesn't use Select to rely on the ActiveSheet - for further reading refer to How to avoid using Select in Excel VBA
The code uses intermediate Range variables to define the range for the table. It starts at cell A2 (startCell) and uses the last cell of the CurrentRegion as endCell.
Dim sheetIndex As Long
For sheetIndex = 3 To ThisWorkbook.Worksheets.Count
With ThisWorkbook.Worksheets(sheetIndex)
If .ListObjects.Count = 0 Then
Dim startcell As Range, endCell As Range, tableRange As Range
Set startcell = .Cells(2, 1)
Set endCell = startcell.CurrentRegion.Cells(startcell.CurrentRegion.Cells.Count)
Set tableRange = .Range(startcell, endCell)
Debug.Print tableRange.Address
.ListObjects.Add(xlSrcRange, tableRange).Name = Replace(.Name, " ", "")
End If
End With
Next sheetIndex
Note that you should always use Option Explicit and declare all Variables and you should never use On Error Resume Next except for single statement where you know that they might fail (and you want to do the error handling by your own).
I have 2 sheets is the CriteriaSheet and DataSheet that need to filter, which use the data in CriteriaSheet to fill in the Criterial argument of AutoFilter for filter data in DataSheet.
DataSheet
CriteriaSheet
My problem is, I want to know which Criteria is cannot find in the DataSheet. How do I know if the "Ant"(Criteria) doesn't exist in the DataSheet?
Function Filter_Function()
Dim Data_sh As Worksheet
Dim Filter_Criteria_Sh As Worksheet
Dim Output_sh As Worksheet
Set Data_sh = ThisWorkbook.Sheets("DataSheet")
Set Filter_Criteria_Sh = ThisWorkbook.Sheets("CriteriaSheet")
Set Output_sh = ThisWorkbook.Sheets("Output")
Output_sh.UsedRange.Clear
Data_sh.AutoFilterMode = False
Dim Emp_list() As String
Dim n, i As Integer
n = Application.WorksheetFunction.CountA(Filter_Criteria_Sh.Range("A:A")) - 2
ReDim Emp_list(n) As String
Dim R As String
For i = 0 To n
Emp_list(i) = Filter_Criteria_Sh.Range("A" & i + 2)
Next i
With Range("A1")
''get range before filter
Dim rngBefore As Range
Set rngBefore = Range(.Offset(1, 0), .Offset(1, 0).End(xlDown))
''filter
Data_sh.UsedRange.AutoFilter 2, Emp_list(), xlFilterValues
''get range after filter
On Error Resume Next
Dim rngAfter As Range
Set rngAfter = rngBefore.SpecialCells(xlCellTypeVisible)
On Error GoTo 0
''check whether any cells matching criteria were found
If rngAfter Is Nothing Then
MsgBox "No found " & Emp_list()
'Exit Function
Else
Data_sh.UsedRange.Copy Output_sh.Range("A1")
End If
End With
Data_sh.AutoFilterMode = False
End Function
Could you please suggest? Thanks
The following code is the one that I'm trying to work with, but I still can't make it work with merge rows. The main idea is to create a loop to check each row from D1:D150 and if the criteria are met then copy the entire row.
This is how my data looks like
Sub attributes()
'--------------------------------------------------------------------
Dim Cel, aCell1, aCell2, aCell3, aCellAsses As Range, ws, ws0 As Worksheet
Dim strAsses1 As Boolean
Dim num As Integer
'------------------------------
Set ws = ActiveWorkbook.Sheets("Contract Attributes")
Set ws0 = ActiveWorkbook.Sheets("ReviewerTab")
ws.Activate
Set aCell1 = ActiveWorkbook.Sheets("Contract Attributes").Range("A1:A150")
'Set aCell1 = ActiveWorkbook.Sheets("Contract Attributes").Range("D1:D150")
'Set aCell2 = ActiveWorkbook.Sheets("Contract Attributes").Range("D:D").Find("Current Modifications", LookIn:=xlValues)
'--------------------------------------------------------------------
strName1 = InputBox("Which contract modification would you like to review?")
num = 5
For Each Cel In aCell1
If InStr(1, Cel, strName1, vbTextCompare) > 0 Or InStr(1, Cel, "x") > 0 Then
Cel.MergeArea.Select
Selection.EntireRow.Copy
ws0.Activate
Rows(num).Insert
ws.Activate
num = num + 1
End If
Next Cel
'--------------------------------------------------------------------
'ws0.Columns(4).Delete
'aCell2.Select
'ActiveCell.EntireRow.Copy
'Sheets("ReviewerTab").Range("A5").Insert
End Sub
TIPS
To begin with, I would recommend that you see How to avoid using Select in Excel VBA. Next you need to identify the range object that you need to copy and then copy them across.
Dim Cel, aCell1, aCell2, aCell3, aCellAsses As Range You need to declare them explicitly else the first four objects are declared as Variant and not Range. For example Dim Cel As Range, aCell1 As Range, aCell2 As Range, aCell3 As Range, aCellAsses As Range
Do not copy the rows in a loop. It will be slow. Identify the rows you want to copy and then copy them in one go. Below is an example
SAMPLE SCENARIO
To demonstrate how this works, I am taking the below sample.
CODE
I have come up with a basic code. I have commented it so you should not have a problem understanding it. But if you do then feel free to ask :).
Option Explicit
Sub Sample()
Dim wsInput As Worksheet
Dim wsOuput As Worksheet
Dim RangeToCopy As Range
Dim lRow As Long, i As Long, num As Long
Dim searchText As Variant
'~~> Row in output sheet where the rows will be copied
num = 5
'~~> Set your input and output sheets
Set wsInput = ThisWorkbook.Sheets("Contract Attributes")
Set wsOuput = ThisWorkbook.Sheets("ReviewerTab")
'~~> Take the input from the user
searchText = InputBox("Which contract modification would you like to review?")
If Len(Trim(searchText)) = 0 Then Exit Sub
With wsInput
lRow = .Range("A" & .Rows.Count).End(xlUp).Row
'~~> Loop through the cells and check for criteria
For i = 1 To lRow
If InStr(1, .Range("A" & i).Value2, searchText, vbTextCompare) Then
'~~> identify the rows you need to copy and store them
'~~> in a range object
If RangeToCopy Is Nothing Then
Set RangeToCopy = .Range("A" & i).MergeArea.EntireRow
Else
Set RangeToCopy = Union(RangeToCopy, .Range("A" & i).MergeArea.EntireRow)
End If
End If
Next i
End With
'~~> Copy them across. You can insert them as well
If Not RangeToCopy Is Nothing Then
RangeToCopy.Copy wsOuput.Rows(num)
End If
End Sub
IN ACTION
You need to include the merge area before "Select".
After you copy the rows, you need to count how many merged rows in the copy. I add a new variable num2 to do so. The loop cannot just simply num=num+1, it varies from what rows copied.
You may try the below code.
Sub attributes()
'--------------------------------------------------------------------
Dim Cel, aCell1, aCell2, aCell3, aCellAsses As Range, ws, ws0 As Worksheet
Dim strAsses1 As Boolean
Dim num As Integer
Dim num2 As Integer
Set ws = ActiveWorkbook.Sheets("Contract Attributes")
Set ws0 = ActiveWorkbook.Sheets("ReviewerTab")
ws.Activate
Set aCell1 = ActiveWorkbook.Sheets("Contract Attributes").Range("A1:A150")
strName1 = InputBox("Which contract modification would you like to review?")
num = 5
For Each Cel In aCell1
If InStr(1, Cel, strName1, vbTextCompare) > 0 Or InStr(1, Cel, "x") > 0 Then
Range(Cells(Cel.Row, 1), Cells(Cel.Row, Cells(Cel.Row, Columns.Count).End(xlToLeft).Column)).Select
num2 = Selection.Rows.Count
Selection.EntireRow.Copy
ws0.Activate
Rows(num).Insert
ws.Activate
num = num + num2
End If
Next Cel
End Sub
My brain is fried and this is easy points for the usual suspects. div is an array holding sheet names. I am looping through sheets in a master book and if one of the master sheets match one of the sheets in the div array, I want to transfer some data from master sheet to a sheet in thisworkbook.
In the event the sheet does not exist in thisworkbook, add one and name it after the master sheet. What's the most efficient way to do this? I feel like nested loops is a bad idea -_- A collection perhaps?
For i = 0 To UBound(div())
For Each s In book.Worksheets
wsName = Left(s.Name, 5)
If div(i) = wsName Then
If wsExists(wsName) Then
Set ws = ThisWorkbook.Worksheets(wsName)
Exit For
'Debug.Print "true " & ws.name
Else
Set ws = ThisWorkbook.Worksheets.Add
ws.Name = Left(s.Name, 5)
'Debug.Print "false " & ws.name
End If
end if
Next
With ws
.Columns(Start).Resize(, 2).Value = s.Columns("A:B").Value
.Columns(Start + label).Resize(, cols).Value = s.Columns(Start + label).Resize(, cols).Value
End With
Next
Do I even need to check if sheet exists? Code stolen from Tim.
Function wsExists(sName As String) As Boolean
Dim sht As Worksheet
On Error Resume Next
Set sht = ThisWorkbook.Sheets(sName)
On Error GoTo 0
wsExists = Not sht Is Nothing
End Function
Edit: I am calling the loop from a separate routine.
Call drop(thisWB, thisRange, ccArr)
where ccArr is
Dim ccArr() As Variant
ccArr = Array("30500", "30510", "30515", "30530", "30600", "30900", "40500")
The routine where above loop resides opens with
Sub drop(book As Workbook, cols As Integer, div As Variant, Optional startCol As Integer)
but I am getting a byref error trying to pass the array ;_;
Your nested loop is superfluous. You can check the sheet name from div directly against the workbook you want to check it against, then add it if needed.
See the code below, which also addresses the concerns in the edits to your OP. I modified the wsExists function to include a set reference to a particular workbook, which I think makes it more dynamic.
'assumes thisWB and thisRange set above
Dim ccArr() As String, sList As String
sList = "30500,30510,30515,30530,30600,30900,40500"
ccArr = Split(sList, ",")
drop thisWB, thisRange, ccArr 'assumes thisWb and thisRange are set already
' rest of code
'==================================================
Sub drop(book As Workbook, cols As Integer, div() As String, Optional startCol as Integer)
For i = 0 To UBound(div())
If wsExists(ThisWorkbook, div(i)) Then
Set ws = ThisWorkbook.Worksheets(div(i))
Exit For
'Debug.Print "true " & ws.name
Else
Set ws = ThisWorkbook.Worksheets.Add
ws.Name = div(i)
End If
'i think you need this here, otherwise, it will only work on the last worksheet in your loop
With ws
Dim s As Worksheet
Set s = book.Sheets(div(i))
.Columns(Start).Resize(, 2).Value = s.Columns("A:B").Value
.Columns(Start + Label).Resize(, cols).Value = s.Columns(Start + Label).Resize(, cols).Value
End With
Next
End Sub
Function wsExists(wb As Workbook, sName As String) As Boolean
Dim sht As Worksheet
On Error Resume Next
Set sht = wb.Sheets(sName)
On Error GoTo 0
wsExists = Not sht Is Nothing
End Function
Related to the re-sizing code:
This statement ws.Columns(1).Resize(, 2) translates to "2 million+ rows from column 1 and 2"
The solution you found works well but it's not dynamic (hard-coded last row)
This is how I'd setup the copy of columns:
Option Explicit
Public Sub copyCols()
Dim ws1 As Worksheet, ws2 As Worksheet, rng1 As Range, rng2 As Range
Dim cols As Long, lr As Long
Dim col1 As Long 'renamed from "Start" (VBA keyword - property)
Dim lbl As Long 'renamed from "label" (VBA keyword - Control object)
Set ws1 = Sheet1 'ws
Set ws2 = Sheet2 'book.Worksheets(wsName & "-F")
col1 = 1
cols = 2
lbl = 1
lr = ws2.Cells(ws2.UsedRange.Row + ws2.UsedRange.Rows.Count, "A").End(xlUp).Row
Set rng1 = ws1.Range(ws1.Cells(1, col1), ws1.Cells(lr, col1 + 1))
Set rng2 = ws2.Range("A1:B" & lr)
rng1.Value2 = rng2.Value2
Set rng1 = ws1.Range(ws1.Cells(1, col1 + lbl), ws1.Cells(lr, col1 + lbl + cols))
Set rng2 = ws2.Range(ws2.Cells(1, col1 + lbl), ws2.Cells(lr, col1 + lbl + cols))
rng1.Value2 = rng2.Value2
End Sub
I would like to export data from a consolidated sheet (DATA) to multiple sheets regarding criteria.
I have a total of 13 criteria, each criteria has to be exported in its dedicated sheet.
I'm trying to optimize this macro (only 2 criteria here) because it lag out
Sub copy()
Application.ScreenUpdating = False
Dim i As Long
Dim j As Long
Dim sh As Worksheet
Dim feuillePrincipale As Worksheet
Dim S01Sheet As Worksheet
Dim S02Sheet As Worksheet
Set feuillePrincipale = ThisWorkbook.Sheets("DATA")
Set S01Sheet = ThisWorkbook.Sheets("S01")
Set S02Sheet = ThisWorkbook.Sheets("S02")
For Each sh In ThisWorkbook.Worksheets
If sh.Name = "S01" Then
i = 2
j = 2
While Not IsEmpty(feuillePrincipale.Cells(i, 1))
If feuillePrincipale.Cells(i, 11).Value Like "S01*" Then
feuillePrincipale.Cells.Rows(i).EntireRow.copy S01Sheet.Rows(j)
j = j + 1
End If
i = i + 1
Wend
End If
If sh.Name = "S02" Then
i = 2
j = 2
While Not IsEmpty(feuillePrincipale.Cells(i, 1))
If feuillePrincipale.Cells(i, 11).Value Like "S02*" Then
feuillePrincipale.Cells.Rows(i).EntireRow.copy S02Sheet.Rows(j)
j = j + 1
End If
i = i + 1
Wend
End If
Next
Application.ScreenUpdating = True
End Sub
If you have any idea, I read I can use Advanced filter but as you guess I'm new in VBA so I'm listening any tips!
Here is the Advanced Filter method you asked for:
Public Sub Christophe()
Const FILTER_COLUMN = 11
Dim i&, rCrit As Range, rData As Range, aShts
aShts = ["SO"&row(1:13)]
Set rData = Sheets("DATA").[a1].CurrentRegion
Set rCrit = rData.Resize(2, 1).Offset(, rData.Columns.Count + 2)
rCrit(1) = rData(1, FILTER_COLUMN)
For i = 1 To UBound(aShts)
rCrit(2) = aShts(i, 1) & "*"
rData.AdvancedFilter xlFilterCopy, rCrit, Sheets(aShts(i, 1)).[a1].Resize(, rData.Columns.Count)
Next
rCrit.Clear
End Sub
The execution time should be instantaneous.
Note: this assumes that you do have 13 criteria, each starting with "SO" and that they occupy column 11 of the Data sheet. It also assumes that you already have 13 sheets named SO1... SO13 in the workbook.
UPDATE
Based on new information that the pattern of the criteria can change, please try this version instead. Note, that it assumes that the sheets already exist and that the sheet names match the criteria:
Public Sub Christophe()
Const FILTER_COLUMN = 11
Dim i&, rCrit As Range, rData As Range, aShts
aShts = Array("SO1", "SO2", "ADQ03", "LocS10")
Set rData = Sheets("DATA").[a1].CurrentRegion
Set rCrit = rData.Resize(2, 1).Offset(, rData.Columns.Count + 2)
rCrit(1) = rData(1, FILTER_COLUMN)
For i = 0 To UBound(aShts)
rCrit(2) = aShts(i) & "*"
rData.AdvancedFilter xlFilterCopy, rCrit, Sheets(aShts(i)).[a1].Resize(, rData.Columns.Count)
Next
rCrit.Clear
End Sub
Try using an array to set your criteria sheets:
Dim shArray As Variant
Dim shArrayString As String
Dim feuillePrincipale As Excel.Worksheet
Dim i As Long
Dim j As Long
Set feuillePrincipale = ThisWorkbook.Sheets("DATA")
j = 1
'// Create array and populate
shArray = Array("S01", "S02", "S03", "S04") '// add as required
'// Create string representation of array
shArrayString = "{"""
For i = LBound(shArray) To UBound(shArray)
shArrayString = shArrayString & shArray(i) & ""","""
Next
shArrayString = Left(shArrayString, Len(shArrayString) - 2) & "}"
'//Start loop
With feuillePrincipale
For i = 2 To .Cells(.Rows.Count, 1).End(xlUp).Row
If Not Evaluate("ISERROR(MATCH(" & Left(.Cells(i, 11), 3) & "," & shArrayString & ",0))") Then
.Rows(i).Copy Sheets(shArray(WorksheetFunction.Match(Left(.Cells(i, 11), 3), shArray, 0))).Cells(j, 1)
j = j + 1
End If
Next
End With
It's a bit unclear because if you follow the code you've posted - it's actually just copying and pasting data to the same sheet...
Yes, you should use an autofilter and use a special select to get only the visible cells.
If you want the loop method, you should loop through each row on sheets("DATA") and use a Select Case Statement to decide onto which sheet the data is placed.
By looping through each sheet you are adding loops that will slow it down.
Application.ScreenUpdating = False
Dim i As Long
Dim j As Long
Dim cel As Range
Dim sh As Worksheet
Dim feuillePrincipale As Worksheet
Dim S01Sheet As Worksheet
Dim S02Sheet As Worksheet
Set feuillePrincipale = ThisWorkbook.Sheets("DATA")
Set S01Sheet = ThisWorkbook.Sheets("S01")
Set S02Sheet = ThisWorkbook.Sheets("S02")
For Each cel In feuillePrincipale.Range(feuillePrincipale.Range("A1"), feuillePrincipale.Range("A1").End(xlDown))
Select Case Left(cel.offset(,10).value, 3)
Case "S01"
j = S01Sheet.Range("A" & Rows.count).End(xlUp).Offset(1).Row
feuillePrincipale.Cells.Rows(cel.Row).EntireRow.copy S01Sheet.Rows(j)
Case "S02"
j = S02Sheet.Range("A" & Rows.count).End(xlUp).Offset(1).Row
feuillePrincipale.Cells.Rows(cel.Row).EntireRow.copy S02Sheet.Rows(j)
'Case .... keep adding select statement till you get to the last condition
Case Else
End Select
Next cel
Application.ScreenUpdating = True