I am hoping someone can help I have the below code which is pasting a new row into a new worksheet in SharePoint with a table. However when it is pasted into the next blank row the table is not changing dynamically with it. Can you please assist.
Sub Complete()
Dim tb1 As ListObject, tb2 As ListObject, tbl As ListObject
Dim Lrow As Long, dRow As Long
Dim ws As Worksheet, ws1 As Worksheet
Dim searchRange As Range, foundCell As Range
Dim mysearch As String
Dim wb As Workbook, Scwb As Workbook
Dim ScRow As Range
Application.DisplayAlerts = False
Set wb = ThisWorkbook
mysearch = Sheets("OI").Range("D4").Value
Set ws = wb.Sheets("OI")
Set tb1 = ws.ListObjects("OITs")
Set tb2 = wb.Sheets("TDets").ListObjects("OIFinal")
Lrow = tb2.ListRows.Count
With ws
.Range("A:A").EntireColumn.Hidden = False
End With
tb1.Range.AutoFilter Field:=11, Criteria1:="<>" & vbNullString
NumRows = tb1.DataBodyRange.Cells.SpecialCells(xlCellTypeVisible).Rows.Count
tb1.DataBodyRange.Cells.SpecialCells(xlCellTypeVisible).Copy
tb2.DataBodyRange(Lrow + 1, 1).PasteSpecial xlPasteValues
Application.CutCopyMode = False
tb1.DataBodyRange.Columns(4).Resize(, 7).ClearContents
tb1.Range.AutoFilter Field:=11, Criteria1:="=" & vbNullString
With ws
.Range("A:A").EntireColumn.Hidden = True
End With
With wb.Sheets("CReqs")
Set searchRange = .Range("G1", .Range("G" & .Rows.Count).End(xlUp))
End With
Set Scwb = Workbooks.Open("https://*****.sharepoint.com/sites/*****/Shared%20Documents/General/NAA/Apps.xlsx")
Set tbl = Scwb.Sheets("AppAccs").ListObjects("Pending")
dRow = tbl.Range.Rows.Count
Set foundCell = searchRange.Find(what:=mysearch, Lookat:=xlWhole, MatchCase:=False, SearchFormat:=False)
If Not foundCell Is Nothing Then
foundCell.Offset(0, 6).Value = "Yes"
foundCell.Offset(0, -6).EntireRow.Copy Destination:=tbl.Range(dRow, "A").Offset(1) ' This is the line that pastes the code to a new wb but does not expand the table.
Scwb.Save
Scwb.Close
Else
MsgBox "We cannot find the ID " & mysearch & " to send for approval. Please check ID."
End If
Application.DisplayAlerts = True
End Sub
I have resolved the above by simply adding tbl.Resize tbl.Range.CurrentRegion to the next line after pasting across to the new SP workbook
Related
I have a string of predefined worksheets, that I need to run specific code for. I get a compile error.
The code is set up to copy data from one sheet to another.
How do I do the same for multiple sheets?
When I step through the code sht is showing the MHP60,MHP61,MHP62 and not just MHP60.
I get a subscript out of range error.
Sub Prepare_CYTD_Report()
Dim addresses() As String
Dim addresses2() As String
Dim SheetNames() As String
Dim SheetNames2() As String
Dim wb1 As Workbook, wb2 As Workbook
Dim my_Filename
'Declare variables for MHP60, MHP61, MHP62 Trial Balance Values
Dim i, lastcol As Long
Dim tabNames, cell As Range
Dim tabName As String
Dim sht As Variant
addresses = Strings.Split("A9,A12:A26,A32:A38,A42:A58,A62:A70,A73:A76,A83:A90", ",") 'Trial Balance string values
addresses2 = Strings.Split("G9,G12:G26,G32:G38,G42:G58,G62:G70,G73:G76,G83:G90", ",") 'Prior Month string values
SheetNames = Strings.Split("MHP60,MHP61,MHP62")
'SheetNames2 = Strings.Split("MHP60-CYTDprior,MHP61-CYTDprior,MHP62-CYTDprior")
Set wb1 = ActiveWorkbook 'Revenue & Expenditure Summary Workbook
'*****************************Open CYTD files
my_Filename = Application.GetOpenFilename(fileFilter:="Excel Files,*.xl*;*.xm*", Title:="Select File to create CYTD Reports")
If my_Filename = False Then
Exit Sub
End If
Application.ScreenUpdating = False
Set wb2 = Workbooks.Open(my_Filename)
'*****************************Load Column Header Strings & Copy Data
For Each sht In SheetNames
lastcol = wb1.Sheets(sht).Cells(5, Columns.Count).End(xlToLeft).Column
On Error Resume Next
Set tabNames = wb1.Sheets(sht).Cells(4, 3).Resize(1, lastcol - 2).SpecialCells(xlCellTypeConstants)
'actual non-formula text values on row 4 from column C up to column lastCol'
On Error GoTo 0
If Err.Number <> 0 Then
MsgBox "No headers were found on row 4 of MHP60", vbCritical
Exit Sub
End If
For Each cell In tabNames
tabName = Strings.Trim(cell.Value2)
'dedicated variable in case of requirement for further parsing (space/comma elimination?)'
If CStr(wb1.Sheets(sht).Evaluate("ISREF('[" & wb2.Name & "]" & tabName & "'!$A$1)")) = "True" Then
'If wb2 has a tab named for the value in tabName
For i = 0 To UBound(addresses)
wb2.Sheets(tabName).Range(addresses(i)).Value2 = wb1.Sheets(sht).Range(addresses(i)).Offset(0, cell.Column - 1).Value2
'Debug.Print "data for " & wb2.Sheets(tabName).Range(addresses(i)).Address(, , , True) & " copied from " & wb1.Sheets("MHP60").Range(addresses(i)).Offset(0, cell.Column - 1).Address(, , , True)
Next i
Else
Debug.Print "A tab " & tabName & " was not found in " & wb2.Name
End If
Next cell
Next sht
MsgBox "CYTD Report Creation Complete", vbOKOnly
Application.ScreenUpdating = True
End Sub
Split by what?
SheetNames = Strings.Split("MHP60,MHP61,MHP62")
Split by comma? Then use the following instead:
SheetNames = Strings.Split("MHP60,MHP61,MHP62", ",")
Alternative
Dim SheetNames() As Variant ' needs to be Variant to work with Array()
SheetNames = Array("MHP60", "MHP61", "MHP62")
This should be quicker as your macro does not need to split the string and has it as array directly.
I have this little code that replaces the letters from a table like this (find the left string and replace it with the right string):
However it takes a great amount of time to do all the replacements in the sheets I have (just 2). Nearly 10 seconds. Is there a way to speed this up pls? Many thanks for taking the time!!
Dim sht As Worksheet
Dim fndList As Integer
Dim rplcList As Integer
Dim tbl As ListObject
Dim myArray As Variant
Dim ReplaceCount As Long
Set sht = Sheets("Sheet1")
Application.ScreenUpdating = False
'Create variable to point to your table
Set tbl = Worksheets("Sheet1").ListObjects("StringReplace")
'Create an Array out of the Table's Data
Set TempArray = tbl.DataBodyRange
myArray = Application.Transpose(TempArray)
'Designate Columns for Find/Replace data
fndList = 1
rplcList = 2
'Loop through each item in Array lists
For x = LBound(myArray, 1) To UBound(myArray, 2)
'Loop through each worksheet in ActiveWorkbook (skip sheet with table in it)
For Each sht In ActiveWorkbook.Worksheets
If sht.Name <> tbl.Parent.Name Then
sht.Cells.Replace What:=myArray(fndList, x), Replacement:=myArray(rplcList, x), _
LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, _
SearchFormat:=False, ReplaceFormat:=False
End If
Next sht
Next x
Application.ScreenUpdating = True
Replace Strings in Multiple Worksheets
The Code
Option Explicit
Sub replaceOddStrings()
Const WorksheetName As String = "Sheet1"
Const TableName As String = "StringReplace"
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Dim Data As Variant: Data = wb.Worksheets(WorksheetName) _
.ListObjects(TableName).DataBodyRange.Value
Dim ws As Worksheet
Dim i As Long
Application.ScreenUpdating = False
For Each ws In wb.Worksheets
If ws.Name <> WorksheetName Then
For i = 1 To UBound(Data, 1)
ws.UsedRange.Replace Data(i, 1), Data(i, 2), xlPart, , False, _
False, False, False
Next i
End If
Next ws
Application.ScreenUpdating = True
MsgBox "Strings replaced.", vbInformation, "Success"
End Sub
The goal is to look through Column A in all Sheets in the array. If "CASH" is found in a cell in Column A, replace Column D of that same row With "USD".
I am hitting an error with the array.range. I realize I can't declare it as is but not sure what to do from here. I will likely his a snag with the loop as well, open to suggestion there too.
Thanks
Sub test()
Dim Sht As Worksheet
Dim SCAFI, ILB, IILB, MMA, IMBD, SCAEQ, IMEQ, IREA, IMSC, ExclSecFI, ExclSecEQ As Worksheet
Dim FIFindCASH, FIFindCASHRng As Variant
Set FIFindCASHRng = Sheets(Array("SCA FI", "ILB", "IILB", "MMA", "IMBD", "Excluded Securities FI")).Range("A:A")
Set SCAFI = Sheets("SCA FI")
Set ILB = Sheets("ILB")
Set IILB = Sheets("IILB")
Set MMA = Sheets("MMA")
Set IMBD = Sheets("IMBD")
Set SCAEQ = Sheets("SCA EQ")
Set IMEQ = Sheets("IMEQ")
Set IREA = Sheets("IREA")
Set IMSC = Sheets("IMSC")
Set ExclSecFI = Sheets("Excluded Securities FI")
Set ExclSecEQ = Sheets("Excluded Securities EQ")
For Each Sht In FIFindCASHRng
If Cell.Value = "CASH" Then
Cell.Value.Offset(0, 3) = "USD"
End If
Next
End Sub
Test the next code, please:
Sub testIterateChangeVal()
Dim wb As Workbook, Sht As Worksheet, i As Long, lastRow As Long
Set wb = ActiveWorkbook 'use here the needed workbook
For Each Sht In wb.Worksheets
Select Case Sht.Name
Case "SCA FI", "ILB", "IILB", "MMA", "IMBD", "Excluded Securities FI"
lastRow = Sht.Range("A" & Rows.count).End(xlUp).Row
For i = 1 To lastRow
If Sht.Range("A" & i).value = "CASH" Then
Sht.Range("A" & i).Offset(0, 3) = "USD"
'or
'Sht.Range("D" & i).value = "USD"
End If
Next i
End Select
Next
End Sub
I have a master file having different account details. I am trying to make a code that will send a copy of the workbook after deleting unnecessary account details and mail it. It is working fine for one sheet but when I am using array for multiple sheets it is giving me object doesn't support method in this line of code ".DisplayPageBreaks = False".
Here is my code:
Sub Mail_Sheets_Array()
'Working in Excel 2000-2016
'For Tips see: http://www.rondebruin.nl/win/winmail/Outlook/tips.htm
Dim FileExtStr As String
Dim FileFormatNum As Long
Dim Sourcewb As Workbook
Dim Destwb As Workbook
Dim TempFilePath As String
Dim TempFileName As String
Dim OutApp As Object
Dim OutMail As Object
Dim sh As Worksheet
Dim TheActiveWindow As Window
Dim TempWindow As Window
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
Set Sourcewb = ActiveWorkbook
'Copy the sheets to a new workbook
'We add a temporary Window to avoid the Copy problem
'if there is a List or Table in one of the sheets and
'if the sheets are grouped
With Sourcewb
Set TheActiveWindow = ActiveWindow
Set TempWindow = .NewWindow
.Sheets(Array("REC_INT", "REC_EXT")).Copy
End With
'Close temporary Window
TempWindow.Close
Set Destwb = ActiveWorkbook
'Determine the Excel version and file extension/format
With Destwb
If Val(Application.Version) < 12 Then
'You use Excel 97-2003
FileExtStr = ".xls": FileFormatNum = -4143
Else
'You use Excel 2007-2016
Select Case Sourcewb.FileFormat
Case 51: FileExtStr = ".xlsx": FileFormatNum = 51
Case 52:
If .HasVBProject Then
FileExtStr = ".xlsm": FileFormatNum = 52
Else
FileExtStr = ".xlsx": FileFormatNum = 51
End If
Case 56: FileExtStr = ".xls": FileFormatNum = 56
Case Else: FileExtStr = ".xlsb": FileFormatNum = 50
End Select
End If
End With
'Change all cells in the worksheets to values if you want
For Each sh In Destwb.Worksheets
sh.Select
With sh.UsedRange
.Cells.Copy
.Cells.PasteSpecial xlPasteValues
.Cells(1).Select
End With
Application.CutCopyMode = False
Destwb.Worksheets(1).Select
Next sh
'Save the new workbook/Mail it/Delete it
TempFilePath = Environ$("temp") & "\"
TempFileName = "Part of " & Sourcewb.name & " " & Format(Now, "dd-mmm-yy h-mm-ss")
'xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
Dim Firstrow As Long
Dim Lastrow As Long
Dim Lrow As Long
Dim prow As Long
Dim r As Long
Dim x As Long
Dim y As Long
Dim CalcMode As Long
Dim ViewMode As Long
r = 0
With Application
CalcMode = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With
'We use the ActiveSheet but you can replace this with
With Destwb.Sheets(Array("REC_INT", "REC_EXT"))
' With ActiveSheet
'We select the sheet so we can change the window view
.Select
'If you are in Page Break Preview Or Page Layout view go
'back to normal view, we do this for speed
ViewMode = ActiveWindow.View
ActiveWindow.View = xlNormalView
'Turn off Page Breaks, we do this for speed
.DisplayPageBreaks = False
'Set the first and last row to loop through
Firstrow = .UsedRange.Cells(1).Row
Lastrow = .UsedRange.Rows(.UsedRange.Rows.Count).Row
'We loop from Lastrow to Firstrow (bottom to top)
For Lrow = 9 To Lastrow Step 1
'We check the values in the A column in this example
With .Cells(Lrow, "C")
If Not IsError(.Value) Then
If Cells(Lrow, "D").Value = "Total" Then
GoTo y
End If
If .Value = Sheet1.Cells(2, 6) Then
r = r + 1
End If
If .Value <> Sheet1.Cells(2, 6) Then
If .Value = "" Then
r = 0
End If
prow = Lrow - r
If Cells(prow, "C").Value = Sheet1.Cells(2, 6) Then
r = r + 1
GoTo x
End If
.EntireRow.ClearContents
'This will delete each row with the Value "ron"
'in Column A, case sensitive.
x:
End If
End If
End With
Next Lrow
End With
ActiveWindow.View = ViewMode
With Application
.ScreenUpdating = True
.Calculation = CalcMode
End With
y:
Range(Cells(9, 3), Cells(Lrow, 3)). _
SpecialCells(xlCellTypeBlanks).EntireRow.Delete
'xxxxxxxxxxxxxxxxxx
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
With Destwb
.SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum
On Error Resume Next
With OutMail
.To = "hadi#siemens.com"
.CC = ""
.BCC = ""
.Subject = "This is the Subject line"
.Body = "Hi there"
.Attachments.Add Destwb.FullName
'You can add other files also like this
'.Attachments.Add ("C:\test.txt")
'.Send 'or use
.Display
End With
On Error GoTo 0
.Close savechanges:=False
End With
'Delete the file you have send
Kill TempFilePath & TempFileName & FileExtStr
Set OutMail = Nothing
Set OutApp = Nothing
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub
You are trying to run a property only supported on a specified sheet, on multiple sheets at once. This is not supported, hence the error 438.
You can try to loop these sheets:
For Each ws In Destwb.Sheets
If ws.Name = "REC_INT" or ws.Name = "REC_EXT" then
Destwb.Worksheets(ws.Name).DisplayPageBreaks = False
End if
Next ws
I think you don't need to check for the sheets names, as you copy just the two of them into a new workbook.
I want to optimize the following code, as it is very slow.
I am using the code found in this answer:
https://stackoverflow.com/a/27108055/1042624
However, it is very slow when looping through +10k rows. Is it possible to optimize my code below? I have tried to modify it a bit, but it does not seem to work.
Sub DeleteCopy2()
Dim LastRow As Long
Dim CurRow As Long
Dim DestLast As Long
Dim strSheetName As String
Dim arrVal() As Long
Application.ScreenUpdating = False
Application.Calculation = xlManual
strSheetName = "Week " & ISOWeekNum(Format(Date)) - 1
LastRow = Sheets("MatchData").Range("A" & Rows.Count).End(xlUp).Row
DestLast = Sheets(strSheetName).Range("A" & Rows.Count).End(xlUp).Row
ReDim arrVal(2 To LastRow) ' Headers in row 1
For CurRow = LBound(arrVal) To UBound(arrVal)
If Not Sheets(strSheetName).Range("A2:A" & DestLast).Find(Sheets("MatchData").Range("A" & CurRow).Value, LookIn:=xlValues, LookAt:=xlWhole) Is Nothing Then
Sheets("MatchData").Range("A" & CurRow).Value = ""
Else
End If
Next CurRow
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
Can you try this for me? I have commented the code so that you will not have a problem understanding it. Also check how much time it takes for 10k+ rows
Logic
Store search values in array 1
Store destination values in array 2
Loop through the first array and check if it is present in the second array. If present, clear it
Clear the search values from sheet1
Output the array to the sheet1
Sort Col A so that the blanks go down.
Code
Sub Sample()
Dim wbMatch As Worksheet, wbDestSheet As Worksheet
Dim lRow As Long, i As Long
Dim MArr As Variant, DArr As Variant
Dim strSheetName As String
Dim rng As Range
strSheetName = "Sheet2" '"Week " & IsoWeekNum(Format(Date)) - 1
'~~> Set your worksheets
Set wbMatch = Sheets("MatchData")
Set wbDestSheet = Sheets(strSheetName)
'~~> Store search values in 1st array
With wbMatch
lRow = .Range("A" & .Rows.Count).End(xlUp).Row
Set rng = .Range("A2:A" & lRow)
MArr = rng.Value
End With
'~~> Store destination values in the 2nd array
With wbDestSheet
lRow = .Range("A" & .Rows.Count).End(xlUp).Row
DArr = .Range("A2:A" & lRow).Value
End With
'~~> Check if the values are in the other array
For i = LBound(MArr) To UBound(MArr)
If IsInArray(MArr(i, 1), DArr) Then MArr(i, 1) = ""
Next i
With wbMatch
'~~> Clear the range for new output
rng.ClearContents
'~~> Output the array to the worksheet
.Range("A2").Resize(UBound(MArr), 1).Value = MArr
'~~> Sort it so that the blanks go down
.Columns(1).Sort Key1:=.Range("A2"), Order1:=xlAscending, Header:=xlYes, OrderCustom:=1, _
MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal
End With
End Sub
'~~> function to check is a value is in another array
Function IsInArray(stringToBeFound As Variant, arr As Variant) As Boolean
Dim j As Long
For j = 1 To UBound(arr, 1)
On Error Resume Next
IsInArray = Application.Match(stringToBeFound, Application.Index(arr, , i), 0)
On Error GoTo 0
If IsInArray = True Then Exit For
Next
End Function
Edit
Another way. Based on the sample file, this code runs in approx 1 minute.
Start : 8/4/2016 08:59:36 PM
End : 8/4/2016 09:00:47 PM
Logic:
It uses CountIf to check for duplicates and then deletes the duplicates using .Autofilter
Sub Sample()
Dim wbMatch As Worksheet, wbDestSheet As Worksheet
Dim lRow As Long
Dim strSheetName As String
Dim rng As Range
Debug.Print "Start : " & Now
strSheetName = "Week " & ISOWeekNum(Format(Date)) - 1
'~~> Set your worksheets
Set wbMatch = Sheets("MatchData")
Set wbDestSheet = Sheets(strSheetName)
'~~> Store search values in 1st array
With wbMatch
lRow = .Range("A" & .Rows.Count).End(xlUp).Row
.Columns(2).Insert
Set rng = .Range("B2:B" & lRow)
lRow = wbDestSheet.Range("A" & wbDestSheet.Rows.Count).End(xlUp).Row
rng.Formula = "=COUNTIF('" & strSheetName & "'!$A$1:$A$" & lRow & ",A2)"
DoEvents
rng.Value = rng.Value
.Range("B1").Value = "Temp"
'Remove any filters
.AutoFilterMode = False
With .Range("A1:E" & lRow) 'Filter, offset(to exclude headers) and delete visible rows
.AutoFilter Field:=2, Criteria1:=">0"
.Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow.Delete
End With
'Remove any filters
.AutoFilterMode = False
.Columns(2).Delete
End With
Debug.Print "End : " & Now
End Sub
Looks like #SiddarthRout and I were working in parallel...
My code example below executes in less than 2 secs (eyeball estimate) over almost 12,000 rows.
Option Explicit
Sub DeleteCopy2()
Dim codeTimer As CTimer
Set codeTimer = New CTimer
codeTimer.StartCounter
Dim thisWB As Workbook
Dim destSH As Worksheet
Dim matchSH As Worksheet
Set thisWB = ThisWorkbook
Set destSH = thisWB.Sheets("Week 32")
Set matchSH = thisWB.Sheets("MatchData")
Dim lastMatchRow As Long
Dim lastDestRow As Long
lastMatchRow = matchSH.Range("A" & matchSH.Rows.Count).End(xlUp).Row
lastDestRow = destSH.Range("A" & matchSH.Rows.Count).End(xlUp).Row
'--- copy working data into memory arrays
Dim destArea As Range
Dim matchData As Variant
Dim destData As Variant
matchData = matchSH.Range("A1").Resize(lastMatchRow, 1)
Set destArea = destSH.Range("A1").Resize(lastDestRow, 1)
destData = destArea
Dim i As Long
For i = 2 To lastDestRow
If Not InMatchingData(matchData, destData(i, 1)) Then
destData(i, 1) = ""
End If
Next i
'--- write the marked up data back to the worksheet
destArea = destData
Debug.Print "Destination rows = " & lastDestRow
Debug.Print "Matching rows = " & lastMatchRow
Debug.Print "Execution time = " & codeTimer.TimeElapsed & " secs"
End Sub
Private Function InMatchingData(ByRef dataArr As Variant, _
ByRef dataVal As Variant) As Boolean
Dim i As Long
InMatchingData = False
For i = LBound(dataArr) To UBound(dataArr)
If dataVal = dataArr(i, 1) Then
InMatchingData = True
Exit For
End If
Next i
End Function
The timing results from my code are (using the timer class from this post ):
Destination rows = 35773
Matching rows = 23848
Execution time = 36128.4913359179 secs