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
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 made this code to create an output sheet where columns from different sheets are sorted by header name and pasted one after the other.
For some reason, it is not pasting the columns underneath each other, but instead overwriting each one with the next:
Dim ws As worksheet
Dim max_ws As worksheet
Dim output_ws As worksheet
Dim max_ws_header As Range
Dim output_ws_header As Range
Dim header_cell As Range
Dim cc As Long
Dim max_cc As Long
Dim output_header_counter As Long
Dim ws_header_counter As Long
Dim output_header_name As String
Dim ws_header_name As String
Application.DisplayAlerts = False
Sheets("indice").Delete
Sheets("aneca").Delete
Application.DisplayAlerts = True
For Each ws In Worksheets
ws.Rows(1).EntireRow.Delete
ws.Columns.Hidden = False
Next ws
max_cc = 0
For Each ws In Worksheets
cc = last_column_index(ws, 1)
If cc > max_cc Then
max_cc = cc
Set max_ws = ws
End If
Next ws
Sheets.Add.Name = "Output"
Set output_ws = Sheets("Output")
Set max_ws_header = max_ws.Range(max_ws.Cells(1, 1), max_ws.Cells(1, max_cc))
Set output_ws_header = output_ws.Range(output_ws.Cells(1, 1), output_ws.Cells(1, max_cc))
max_ws_header.Copy output_ws_header
For Each ws In Worksheets
If ws.Name <> "Output" Then
For output_header_counter = 1 To max_cc
output_header_name = output_ws.Cells(1, output_header_counter).Value
For ws_header_counter = 1 To max_cc
ws_header_name = ws.Cells(1, ws_header_counter).Value
If ws_header_name = output_header_name Then
ws.Range(Cells(1, ws_header_counter), Cells(last_row_index(ws, ws_header_counter), ws_header_counter)).Copy _
output_ws.Range(Cells(last_row_index(output_ws, output_header_counter) + 1, output_header_counter), Cells(last_row_index(ws, ws_header_counter), output_header_counter))
End If
Next ws_header_counter
Next output_header_counter
End If
The functions last_row_index and last_column_index are UDFs that I made as follows:
Function last_row_index(target_worksheet As worksheet, target_column_index As Long) As Long
last_row_index = target_worksheet.Cells(Rows.Count, target_column_index).End(xlUp).Row
End Function
Function last_column_index(target_worksheet As worksheet, target_row_index As Long) As Long
last_column_index = target_worksheet.Cells(target_row_index, Columns.Count).End(xlToLeft).Column
End Function
Here is an example of the output:
I figured out the solution, posting it here to close the question:
For Each ws In Worksheets
If ws.Name <> "Output" And ws.Name <> "indice" And ws.Name <> "aneca" Then
For row_index = 2 To last_row_index(ws, 1)
output_counter = last_row_index(output_ws, 1)
For column_index = 1 To last_column_index(ws, 1)
ws_header = ws.Cells(1, column_index).Value
For o_column_index = 1 To max_cc
output_header = output_ws.Cells(1, o_column_index).Value
If output_header = ws_header Then
ws.Cells(row_index, column_index).Copy output_ws.Cells(output_counter + 1, column_index)
Exit For
End If
Next o_column_index
Next column_index
Next row_index
End If
Next ws
I made an output counter variable and made it find the last row each time it starts on a new row in the input sheets, and then I add +1 to it every time it pastes a row.
I have got an excel workbook, it has 5 static tabs and more tabs can be created using a template tab.
In each tab there is a certain field or a range that is mandatory to be filled out also in the new created tabs (might be up to 60).
My question is how can I go about seeing in, lets say in mainsheet, a summary which shows me:
Which tab has missing fields
Which fields is missing (an address of a cell)
I tried naming the range "MyRange" and counting if the cells are non blank.
But this will not work for the newly created sheets.
I also tried a conditional formatting but again this will not give me a summary.
In the meantime I also bumped into a sort of solution but this is also not the thing I am looking for:
Sub listEmptyCells()
Dim emptyAddresses() As String
Dim i As Long
Dim ws As Worksheet
Dim rng As Range
Set ws = Sheets("1.Data Source") ' CHANGE AS NECESSARY
Set rng = ws.Range("B30:B32")
If WorksheetFunction.CountBlank(rng) = 0 Then
MsgBox ("No empty cells in the range")
Exit Sub
End If
emptyAddresses() = Split(rng.SpecialCells(xlCellTypeBlanks).Address, ",")
For i = LBound(emptyAddresses) To UBound(emptyAddresses)
ws.Cells(i + 1, 2).Value = emptyAddresses(i)
Next i
End Sub
Your help and guidance here would be highly appreciated
All the best
Jacek
Here's one approach:
Sub listEmptyCells()
Const CHECK_RANGE As String = "B30:B32" 'range to locate empty cells in
Dim i As Long, r As Long, rngCheck As Range, rngEmpty As Range
Dim ws As Worksheet, wb As Workbook, wsSummary As Worksheet
Dim rwSummary As Range, s As String, c As Range
Set wb = ThisWorkbook
Set wsSummary = wb.Worksheets("Summary")
Set rwSummary = wsSummary.Range("A2:B2") 'first row of results
rwSummary.Resize(wb.Worksheets.Count).Clear 'remove previous results
For i = 1 To wb.Worksheets.Count
Set ws = wb.Worksheets(i)
If ws.Name <> wsSummary.Name Then 'exclude specific sheet(s)
s = ""
Set rngEmpty = Nothing
'which range to check - special case or use default?
Select Case ws.Name
Case "Sheet One": Set rngCheck = ws.Range("A1:A10")
Case "Sheet Two": Set rngCheck = ws.Range("G34:G56,H10")
Case Else: Set rngCheck = ws.Range(CHECK_RANGE) 'default range
End Select
'loop cells in check range
For Each c In rngCheck.Cells
If Len(c.Value) = 0 Then
If rngEmpty Is Nothing Then
Set rngEmpty = c
Else
Set rngEmpty = Application.Union(rngEmpty, c)
End If
End If
Next c
If Not rngEmpty Is Nothing Then
s = rngEmpty.Count & " required cell(s) not filled:" & _
rngEmpty.Address(False, False)
End If
With rwSummary 'record results
.Cells(1).Value = ws.Name
.Cells(2).Value = IIf(s <> "", s, "OK")
.Font.Color = IIf(s <> "", vbRed, vbGreen)
End With
Set rwSummary = rwSummary.Offset(1, 0) 'next summary row
End If
Next i
End Sub
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
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