VBA Excel Incremented worksheet name Add After Statement using a stored variable sheet name - excel

How to add a worksheet in excel with VBA after a specific sheetname held by variable?
I tried:
Set sh = wb.Worksheets.Add(After:=wb.Sheets(wsPattern & CStr(n)))
The previous incremented sheetname is stored in "wsPattern & CStr(n)", The new sheetname increments up properly from another statement and variable, but the add after fails with the above syntax. I'm getting an out of range error at this line.
The code fully executes using this statement, but adds any newly created sheets from any given series at the end of all sheets:
Set sh = wb.Worksheets.Add(After:=wb.Sheets(wb.Sheets.Count))
As the workbook has 4 series of sheet names now (e.g. Test1, logistic1, Equip1, Veh1, etc.) that are incremented up as they are added, the next incremented sheet for a given series needs to be added to the end of that sheet name series (Equip2 should be after Equip1) and not at the end of all sheets.
Sub CreaIncWkshtEquip()
Const wsPattern As String = "Equip "
Dim wb As Workbook: Set wb = ThisWorkbook
Dim arr() As Long: ReDim arr(1 To wb.Sheets.Count)
Dim wsLen As Long: wsLen = Len(wsPattern)
Dim sh As Object
Dim cValue As Variant
Dim shName As String
Dim n As Long
For Each sh In wb.Sheets
shName = sh.Name
If StrComp(Left(shName, wsLen), wsPattern, vbTextCompare) = 0 Then
cValue = Right(shName, Len(shName) - wsLen)
If IsNumeric(cValue) Then
n = n + 1
arr(n) = CLng(cValue)
End If
End If
Next sh
If n = 0 Then
n = 1
Else
ReDim Preserve arr(1 To n)
For n = 1 To n
If IsError(Application.Match(n, arr, 0)) Then
Exit For
End If
Next n
End If
'adds to very end of workbook
'Set sh = wb.Worksheets.Add(After:=wb.Sheets(wb.Sheets.Count))
'Test-Add After Last Incremented Sheet-
Set sh = wb.Worksheets.Add(After:=wb.Sheets(wsPattern & CStr(n)))
sh.Name = wsPattern & CStr(n)
End Sub

Create a function
Sub Demo()
Dim s
s = AddSheet("SeriesName")
MsgBox s & " Added"
End Sub
Function AddSheet(sSeries As String) As String
Dim ws, s As String, i As Long, n As Long
With ThisWorkbook
' find last in series
For n = .Sheets.Count To 1 Step -1
s = .Sheets(n).Name
If s Like sSeries & "[1-9]*" Then
i = Mid(s, Len(sSeries) + 1)
Exit For
End If
Next
' not found add to end
If i = 0 Then
n = .Sheets.Count
End If
' increment series
s = sSeries & i + 1
.Sheets.Add after:=.Sheets(n)
.Sheets(n + 1).Name = s
End With
AddSheet = s
End Function

Related

Highlight Differences across Workbook Ranges VBA

I've managed to compare 3 separate ranges on one workbook with 3 single ranges across 3 workbooks. Right now it's written to just pop up with a message box either letting me know the data is the same or the data is different. What I would like to do is for the macro to not only let me know there are differences, but to also highlight where the differences are to me. I guess this could be done by just highlighting the cells on the first workbook that are different to the other three or I guess it could also be done by pasting the different values on the sheets in question from COL N onward.
Sub Macro1()
Dim varDataMatrix() As Variant
Dim varDataMatrix2() As Variant
Dim varDataMatrix3() As Variant
Dim lngArrayCount As Long
Dim lngArrayCount2 As Long
Dim lngArrayCount3 As Long
Dim rngMyCell As Range
Dim rngMyCell2 As Range
Dim rngMyCell3 As Range
Dim wbWorkbookOne As Workbook
Dim wbWorkbookTwo As Workbook
Dim wbWorkbookThree As Workbook
Dim wbWorkbookFour As Workbook
Application.ScreenUpdating = False
Set wbWorkbookOne = Workbooks("PositionTest.xls")
Set wbWorkbookTwo = Workbooks("ATest.xlsx")
Set wbWorkbookThree = Workbooks("BTest.xlsx")
Set wbWorkbookFour = Workbooks("CTest.xlsx")
'First create an array of the values in the desired range of the first workbook.
For Each rngMyCell In wbWorkbookOne.Sheets("Positions").Range("B3:B6")
lngArrayCount = lngArrayCount + 1
ReDim Preserve varDataMatrix(1 To lngArrayCount)
varDataMatrix(lngArrayCount) = rngMyCell
Next rngMyCell
lngArrayCount = 0 'Initialise variable
'Loop through Array elements
For Each rngMyCell In wbWorkbookTwo.Sheets("A").Range("B2:B5")
lngArrayCount = lngArrayCount + 1
If rngMyCell.Value <> varDataMatrix(lngArrayCount) Then
GoTo QuitRoutinue
End If
Next rngMyCell
For Each rngMyCell2 In wbWorkbookOne.Sheets("Positions").Range("F3:F6")
lngArrayCount2 = lngArrayCount2 + 1
ReDim Preserve varDataMatrix2(1 To lngArrayCount2)
varDataMatrix2(lngArrayCount2) = rngMyCell2
Next rngMyCell2
lngArrayCount2 = 0 'Initialise variable
'Loop through Array elements
For Each rngMyCell2 In wbWorkbookThree.Sheets("B").Range("B2:B5")
lngArrayCount2 = lngArrayCount2 + 1
If rngMyCell2.Value <> varDataMatrix2(lngArrayCount2) Then
GoTo QuitRoutinue
End If
Next rngMyCell2
For Each rngMyCell3 In wbWorkbookOne.Sheets("Positions").Range("J3:J6")
lngArrayCount3 = lngArrayCount3 + 1
ReDim Preserve varDataMatrix3(1 To lngArrayCount3) 'Append the record to the existing array
varDataMatrix3(lngArrayCount3) = rngMyCell3
Next rngMyCell3
lngArrayCount3 = 0 'Initialise variable
For Each rngMyCell3 In wbWorkbookFour.Sheets("C").Range("B2:B5") 'Workbook one range is A10:A15 on 'Sheet2'.
lngArrayCount3 = lngArrayCount3 + 1
If rngMyCell3.Value <> varDataMatrix3(lngArrayCount3) Then
GoTo QuitRoutinue
End If
Next rngMyCell3
'If we get here both datasets have matched.
Set wbWorkbookOne = Nothing
Set wbWorkbookTwo = Nothing
Application.ScreenUpdating = True
Erase varDataMatrix() 'Deletes the varible contents, free some memory
MsgBox "Data is the same.", vbInformation
Exit Sub
Set wbWorkbookOne = Nothing
Set wbWorkbookTwo = Nothing
Application.ScreenUpdating = True
Erase varDataMatrix() 'Deletes the varible contents, free some memory
MsgBox "Data is different.", vbExclamation
End Sub
Highlights differences on Positions sheet and shows values in columns L to N. Uses Application.Transpose to create 1D arrays from a vertical range of cells. Note : Transpose won't work for a non-contiguous range.
Option Explicit
Sub Macro2()
Dim ws(3) As Worksheet, sht, w, n As Long
sht = Array("Positions", "A", "B", "C")
For Each w In Array("PositionTest.xls", "ATest.xlsx", "BTest.xlsx", "CTest.xlsx")
Set ws(n) = Workbooks(w).Sheets(sht(n))
n = n + 1
Next
Dim i As Long, r As Long, diff As Long
Dim rng0 As Range, rngN As Range, a As Range, b As Range
Dim ar0, arN
' compare sheets
For n = 1 To 3
Set rng0 = ws(0).Range("H5:H7,H9:H11,H13:H19,H21:H22").Offset(, (n - 1) * 4) ' H, L, P
Set rngN = ws(n).Range("E3:E18") ' sheet A, B, C
' copy to array
arN = Application.Transpose(rngN)
i = 0
For Each a In rng0
i = i + 1
r = a.Row
' cells on position sheet
Set b = ws(0).Cells(r, "R").Offset(, n) ' diff in col L,M,N
' compare arrays
If a.Value <> arN(i) Then
a.Interior.Color = RGB(255, 255, 0) ' yellow
b.Value = rngN.Cells(i, 1)
diff = diff + 1
Else
a.Interior.Pattern = False
b.Clear
End If
Next
Next
MsgBox diff & " differences", vbInformation
End Sub

Vba: Delete excel sheets not mentioned in the list (the list only contains numeric value)

I need to delete sheets not mentioned in the given list(Range is A7:A350).
I found this vba but the problem is it deletes all the sheets from my workbook, maybe because sheetname is in numeric. I would really appreciate any help.
Sub Deletenotinlist()
Dim i As Long
Dim cnt As Long
Dim xWb, actWs As Worksheet
Set actWs = ThisWorkbook.ActiveSheet
cnt = 0
Application.DisplayAlerts = False
For i = Sheets.Count To 1 Step -1
If Not ThisWorkbook.Sheets(i) Is actWs Then
xWb = Application.Match(Sheets(i).Name, actWs.Range("A7:A350"), 0)
If IsError(xWb) Then
ThisWorkbook.Sheets(i).Delete
cnt = cnt + 1
End If
End If
Next
Application.DisplayAlerts = True
If cnt = 0 Then
MsgBox "Not find the sheets to be seleted", vbInformation, "Kutools for Excel"
Else
MsgBox "Have deleted" & cnt & "worksheets"
End If
End Sub
I think I would do it this way.
Sub DeleteSheets()
Dim sht As Worksheet
Dim rng As Range
Set rng = Sheets("Sheet1").Range("A2:A10")
Application.DisplayAlerts = False
For Each sht In ActiveWorkbook.Worksheets
If Application.CountIf(rng, sht.Name) = 0 Then
sht.Delete
End If
Next sht
Application.DisplayAlerts = True
End Sub
What you try doing can be accomplished in many ways, but I tried adapting your code to place the missing sheets name in an array and select them at the end. If selection is convenient, you can replace Select with Delete:
Sub Deletenotinlist()
Dim i As Long, cnt As Long, xWb, actWs As Worksheet, lastR As Long, arrSh(), k As Long
Set actWs = ThisWorkbook.ActiveSheet
lastR = actWs.Range("A" & actWs.rows.count).End(xlUp).row
ReDim arrSh(ThisWorkbook.Sheets.count - 1)
cnt = 0
For i = 1 To Sheets.count
If Not ThisWorkbook.Sheets(i) Is actWs Then
xWb = Application.match(Sheets(i).Name, actWs.Range("A7:A" & lastR), 0)
If IsError(xWb) Then
arrSh(k) = CStr(ThisWorkbook.Sheets(i).Name): k = k + 1
cnt = cnt + 1
End If
End If
Next
ReDim Preserve arrSh(k - 1) 'keep only the filled array elements
Sheets(arrSh).Select 'You can replace 'Select' with 'Delete', if it returns correctly
If cnt = 0 Then
MsgBox "Not find the sheets to be seleted", vbInformation, "Kutools for Excel"
Else
MsgBox "Have deleted " & cnt & " worksheets"
End If
End Sub
It processes all existing values in column A:A, starting from the 7th row.
But I'm afraid that the range you try processing does not contain any existing sheet name...
In order to test the above supposition, please run the next test sub, which will place all existing sheets name in column B:B, starting from the 7th row. Then delete some rows and run the previous code, replacing "A" with "B" in lastR = actWs.Range("A" &... and actWs.Range("A7:A" & lastR). The code should select all missing sheets:
Sub testArraySheets()
Dim arrSh, ws As Worksheet, k As Long
ReDim arrSh(ActiveWorkbook.Sheets.count - 1)
For Each ws In ActiveWorkbook.Sheets
If Not ws Is ActiveSheet Then
arrSh(k) = ws.Name: k = k + 1
End If
Next
ActiveSheet.Range("B7").Resize(UBound(arrSh) + 1, 1).Value = Application.Transpose(arrSh)
End Sub

VBA - Get the name of all ActiveSheets

The following code returns the name of all the worksheets from the workbook. What I would like it to do is to return only the name of my active sheets.
I have multiple Sheets selected
What do I need to change to correct it? I suppose it's in that "For each" section
Sub test()
Dim ws As Worksheet
Set ws = ActiveSheet
Dim x As Integer
x = 0
Dim aSheetnames As Variant
aSheetnames = Array("")
For Each ws In Worksheets
'Redimensiona array
ReDim Preserve aSheetnames(x)
aSheetnames(x) = ws.Name
x = x + 1
Next ws
Dim str As String
For j = LBound(aSheetnames) To UBound(aSheetnames)
str = str & aSheetnames(j) & Chr(13)
Next j
MsgBox str
End Sub
You can use the following code snippet to get all selected sheets.
ActiveWorkbook.Windows(1).SelectedSheets
Description: SelectedSheets
Otherwise you can also get the name of the activated sheet with
ThisWorkbook.ActiveSheet.Name
Description: ActiveSheet
In your case you have to change the For loop as follows:
For Each ws In ActiveWorkbook.Windows(1).SelectedSheets
ReDim Preserve aSheetnames(x)
aSheetnames(x) = ws.Name
x = x + 1
Next ws

Copy paste using loop from multiple ranges to single row into another WB

I am trying to copy data from multiple source files into a destination file.
So a folder has all the source files I receive.
I now have to collate the data from the files received into a single workbook.
Source file
Destination file/Collation file
I am trying to get some help in collating from each source file in the folder into the destination file.
Sub Transfer_data()
Dim wb As String
Dim i As Long
Dim j As Long
Dim lr As Long
Application.ScreenUpdating = False
i = 0
j = 0
wb = Dir(ThisWorkbook.Path & "\*")
Do Until wb = ""
If wb <> ThisWorkbook.Name Then
Workbooks.Open ThisWorkbook.Path & "\" & wb
With Workbooks(wb).Sheets("D. P & c data")
For i = 21 To 26
For j = 3 To 60 Step 10
.Range(Cells(i, 3), Cells(i, 12)).Copy ThisWorkbook.Sheets("P and c data").Cells(Rows.Count, j).End(xlUp).Offset(1)
Next j
Next i
End With
Application.CutCopyMode = False
Workbooks(wb).Close True
End If
wb = Dir
Loop
Application.ScreenUpdating = True
MsgBox " Copy Complete"
End Sub
I am unsure of what is going on in your code before and after the loop. I think the below loop is what you are looking for. Putting rows outside of columns is easier.
For i = 21 To 26
For j = 3 To 13
Dim lr As Long
lr = ThisWorkbook.Sheets("P and c data").Range("C" & Rows.Count).End(xlUp).Row + 1
Cells(i, j).Copy
Sheets("P and c data").Cells(lr, 3).PasteSpecial
Next j
Next i
Copy Range by Row to Single Row
Option Explicit
' Copies values from a specified range (srcAddr)
' in a specified worksheet (srcID) in all workbooks ("*.xls*") in the folder
' of ThisWorkbook (ThisWorkbook excluded), to a specified worksheet (tgtID)
' in ThisWorkbook. The values of the range are copied into a single row
' starting from a specified column (tgtCol), each row of the range next
' to the previous.
Sub transferData()
Const srcID As Variant = "D. P & c data" ' Name or Index e.g. "Sheet1" or 1
Const srcAddr As String = "C21:L26"
Const tgtID As Variant = "P and c data" ' Name or Index e.g. "Sheet1" or 1
Const tgtCol As Variant = 3 ' Number or String e.g. 1 or "A"
Const Pattern As String = "*.xls*"
Dim wbPath As String: wbPath = ThisWorkbook.Path & Application.PathSeparator
Dim tgt As Worksheet: Set tgt = ThisWorkbook.Worksheets(tgtID)
Application.ScreenUpdating = False
Dim wb As Workbook, src As Worksheet, tgtCell As Range ' Objects
Dim Source As Variant, Target As Variant ' Arrays
Dim i As Long, j As Long, l As Long, Count As Long ' Counters (Longs)
Dim wbname As String: wbname = Dir(wbPath & Pattern)
Do Until wbname = ""
If wbname <> ThisWorkbook.Name Then
GoSub readSource
GoSub writeSource
GoSub writeTarget
End If
WorksheetNotFound:
wbname = Dir
Loop
Application.ScreenUpdating = True
MsgBox "Copied data from " & Count & " workbook(s) containing " _
& "a worksheet ID-ed with '" & srcID & "'.", _
vbInformation, "Data Transfer"
Exit Sub
readSource:
' Write values from Source Range to Source Array.
On Error Resume Next
Set src = Workbooks.Open(wbPath & wbname).Worksheets(srcID)
If Err.Number <> 0 Then GoTo closeSourceError
On Error GoTo 0
Source = src.Range(srcAddr).Value
' Uncomment the following line to write the names of the worksheets
' and the workbooks (that were read from) to the Immediate window (CTRL+G).
Debug.Print src.Name, src.Parent.Name
src.Parent.Close False ' Just reading, no need to save.
Return
writeSource:
' Write values from Source Array to Target Array.
ReDim Target(1 To 1, 1 To UBound(Source) * UBound(Source, 2))
l = 0
For i = 1 To UBound(Source)
For j = 1 To UBound(Source, 2)
l = l + 1
Target(1, l) = Source(i, j)
Next j
Next i
Return
writeTarget:
' Write values from Target Array to Target Range.
Set tgtCell = tgt.Cells(tgt.Rows.Count, tgtCol).End(xlUp).Offset(1)
tgtCell.Resize(, UBound(Target, 2)).Value = Target
Count = Count + 1
Return
closeSourceError:
src.Parent.Close False ' Just reading, no need to save.
On Error GoTo 0
GoTo WorksheetNotFound
End Sub

Excel 2013 Overflow due to lack of VBA optimization

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

Resources