I have some background with VBA and I hate doing the same task 100's of times. I often have to make Solidworks drawings,these drawings are templates that are mostly just tables that I populate with data. There are 3 things that need to be changed on each sheet in the file (from sheet 3 to the last sheet). Normally I go into each sheet and do 3 find and replaces to change each sheet. then move on to the next sheet and repeat.
My plan was to have the code count the number of sheets, prompt the user for the first find/replace, replace that text on all sheets, then repeat for the 2nd replace, and again for the 3rd. I recorded a macro and added some code but I keep getting run-time errors (in code below). Every other macro I've recorded never gave me so many errors, if you can please help
Dim swApp As SldWorks.SldWorks
Dim swmodel As SldWorks.ModelDoc2
Dim swdraw As SldWorks.DrawingDoc
Dim Part As Object
Dim Otext As String
Dim Ntext As String
Dim Smax As Integer
Dim i As Integer
Dim swSheet As SldWorks.Sheet
Dim boolstatus As Boolean
Dim longstatus As Long, longwarnings As Long
Sub main()
Set swApp = Application.SldWorks
Set swmodel = swApp.ActiveDoc
'Set swSheet = swdraw.GetCurrentSheet
Smax = instance.GetSheetCount() - 3 ' runtime 424 error here
Set swSheet = swdraw.GetCurrentSheet ' runtime 91 error if i skip the line above
Otext = Application.InputBox("find this text")
Ntext = Application.InputBox("find this text")
For i = 1 To Smax
Set Part = swApp.ActiveDoc
'--------------------Find and Replace Annotations--------------------
Set swUtil = swApp.GetAddInObject("Utilities.UtilitiesApp")
Set swUtilFindReplaceAnnotations = swUtil.FindReplaceAnnotations
longstatus = swUtilFindReplaceAnnotations.InitPMPage()
'--------------------Block Recording--------------------
#If 0 Then
#End If
'--------------------UnBlock Recording------------------
swUtilFindReplaceAnnotations.FindText = Otext
swUtilFindReplaceAnnotations.ReplaceText = Ntext
swUtilFindReplaceAnnotations.options = gtFraMatchCase
swUtilFindReplaceAnnotations.AnnotationFilter = gtFraAllTypes
Part.ClearSelection2 True
Part.ClearSelection2 True
Part.ClearSelection2 True
Part.ClearSelection2 True
Part.ClearSelection2 True
longstatus = swUtilFindReplaceAnnotations.ReplaceAll()
'--------------------Block Recording--------------------
#If 0 Then
#End If
'--------------------UnBlock Recording------------------
longstatus = swUtilFindReplaceAnnotations.Close()
Part.SheetNext
Part.ViewZoomtofit2
Next i
End Sub
This should do the trick. It will popup a success window for each sheet however as that is how the SOLIDWORKS find replace utility works.
Dim swApp As SldWorks.SldWorks
Dim swModel As SldWorks.ModelDoc2
Dim swDrawingDoc As SldWorks.DrawingDoc
Dim vSheetNames As Variant
Dim longstatus As Long
Sub main()
Set swApp = Application.SldWorks
Set swModel = swApp.ActiveDoc
Set swDrawingDoc = swModel
vSheetNames = swDrawingDoc.GetSheetNames
Otext = InputBox("find this text")
Ntext = InputBox("find this text")
For i = 0 To UBound(vSheetNames)
swDrawingDoc.ActivateSheet (vSheetNames(i))
Set swUtil = swApp.GetAddInObject("Utilities.UtilitiesApp")
Set swUtilFindReplaceAnnotations = swUtil.FindReplaceAnnotations
longstatus = swUtilFindReplaceAnnotations.InitPMPage()
swUtilFindReplaceAnnotations.FindText = Otext
swUtilFindReplaceAnnotations.ReplaceText = Ntext
swUtilFindReplaceAnnotations.Options = gtFraWholeWord
swUtilFindReplaceAnnotations.AnnotationFilter = gtFraAllTypes
longstatus = swUtilFindReplaceAnnotations.ReplaceAll()
longstatus = swUtilFindReplaceAnnotations.Close()
Next i
End Sub
Related
I'm currently working with a workbook containing 34 different tabs.
I'm trying to extract Monthly Data from each of the tabs and Transpose it into daily figures for each specific city.
I have put all the dates within the year 2019 as columns in order to present it as daily figures. (See example in img below)
Each tab contains data for each specific city.
I always want to extract the data present on row 20 from column 4 to 15 in each tab for each specific city. ( see 2nd image below highlighted in yellow)
Public Sub CreateArray()
Dim myArrayOfMonths(11) As Double
Dim currentWorkbook As Workbook
Dim currentSheet As Worksheet
Dim otherSheet As Worksheet
Dim i As Integer
Dim r As Integer
Dim c As Integer
Dim j As Integer
Set currentWorkbook = ActiveWorkbook
Set otherSheet = currentWorkbook.Worksheets("Output")
i = 1
For Each currentSheet In currentWorkbook.Worksheets
r = 20
j = 0
For c = 4 To 15
myArrayOfMonths(j) = ActiveSheet.Cells(r, c)
j = j + 1
Next c
Debug.Print myArrayOfMonths(0)
i = i + 1
Next currentSheet
Set currentSheet = Nothing
Set currentWorkbook = Nothing
End Sub
In my code I'm trying to run through all of the tabs with a loop
and with a 2nd loop check the date (row 16, column 4 to 15) and extract it on my template (Similiar to a vlookup) Unfortunately, it never passes through the first tab as i=0 always for some reason.
Could you please advise?
Would you be able to do something like this?
Option Explicit
Public Sub PopulateOutput()
Dim outputSheet As Worksheet
Dim i As Integer
Set outputSheet = ActiveWorkbook.Worksheets("Output")
' starting at index 2 since output sheet looks like index 1
For i = 2 To ActiveWorkbook.Worksheets.Count
With ActiveWorkbook.Worksheets(i)
outputSheet.Range("B" & i & ":M" & i).Value = .Range("D20:O20").Value
End With
Next
End Sub
Does this suit your needs?
Public Sub CreateArray()
Dim myArrayOfMonths(11) As Double
Dim currentWorkbook As Workbook
Dim currentSheet As Worksheet
Dim otherSheet As Worksheet
Dim r As Integer
Dim c As Integer
Set currentWorkbook = ActiveWorkbook
Set otherSheet = currentWorkbook.Worksheets("Output")
For Each currentSheet In currentWorkbook.Worksheets
r = 20
For c = 4 To 15
myArrayOfMonths(c - 4) = myArrayOfMonths(c - 4) + currentSheet.Cells(r, c)
Next c
Next currentSheet
otherSheet.Range("B1:M1").Value = myArrayOfMonths
Set currentSheet = Nothing
Set currentWorkbook = Nothing
End Sub
Use currentSheet.Cells(r,c) instead of ActiveSheet
or use currentSheet.Activate and then myArrayOfMonths(j) = ActiveSheet.Cells(r, c), but try to avoid ActiveSheet.
Sub test()
Dim myVar(): myVar = getHeadingTOC(ActiveDocument)
myVar(9, 2).Follow '9 is not significant; randomly chosen for test
End Sub
Function getHeadingTOC(oDoc As Document) As Variant
Dim Match, Matches, varArray
Dim item As Long, subItem As Long
Dim rgx As Object: Set rgx = CreateObject("VBScript.RegExp")
Dim ptrn As String: ptrn = "([\d\.]*)\s(.*)"
Dim rng As Range: Set rng = oDoc.Range(0, 0): rng.MoveStart wdStory, 9
Dim toc As TableOfContents
' On Error GoTo housekeeping
With rgx
.Pattern = ptrn
.MultiLine = False
.Global = True
.IgnoreCase = True
End With
Set toc = oDoc.TablesOfContents.Add(Range:=rng, UseHeadingStyles:=True, UpperHeadingLevel:=1, LowerHeadingLevel:=7, IncludePageNumbers:=False, UseHyperlinks:=True)
With toc.Range
ReDim varArray(1 To .Paragraphs.Count, 0 To 2)
For item = 1 To .Paragraphs.Count
With .Paragraphs(item).Range
Set Matches = rgx.Execute(Trim$(.Text))
For Each Match In Matches
For subItem = 0 To Match.Submatches.Count - 1
varArray(item, subItem) = Match.Submatches(subItem)
Next subItem
Set varArray(item, 2) = .Hyperlinks(1)
Next Match
End With
Next item
End With
getHeadingTOC = varArray
housekeeping:
If Not toc Is Nothing Then toc.Delete
Set toc = Nothing
Set Match = Nothing
Set Matches = Nothing
Set rgx = Nothing
Set rng = Nothing
End Function
getHeadingTOC returns a 2-dimensional variant array of the following types:
- myVar(X,0) is a String
- myVar(X,1) is a String
- myVar(X,2) is a Word.Hyperlink object
By Inspection, the array leaves the providing function (getHeadingTOC) containing the desired hyperlink but the array arrives at _test with the hyperlinks deleted and thus fails (5825 error is generated) when attempting to execute the Follow command.
What am I missing about this unexpected behavior?
Can anybody help me edit? I want to copy from column to another workbook column using array.
The range inside the array is the Alphabet of the column i want to copy/paste.
Sub setting2()
Dim wb As ThisWorkbook
Dim here As Workbook
Dim there As Workbook
Dim source() As Variant
Dim log() As Variant
Dim LastRowHere() As Integer
Dim LastRowThere() As Integer
'Open both workbooks first:
Set here = Workbooks.Open("C:\Users\jesslynn\Desktop\macro\Setting2.xlsm")
Set there =Workbooks.Open("C:\Users\jesslynn\Desktop\macro\Setting3.xlsm")
Windows("Setting.xlsm").Activate
source() = Array(Sheets("Sheet1").Range("E11"), Range("E12"), Range("E13"), Range("E14"), Range("E15"), Range("E16"),Range("E17").Value)
Windows("Setting.xlsm").Activate
log() = Array(Sheets("Sheet1").Range("J11"), Range("J12"),Range("J13"),Range("J14"), Range("J15"), Range("J16"), Range("J17").Value)
Windows("Setting2.xlsm").Activate
LastRowHere() = Array(Sheets("Sheet1").Rows.Count, source().End(xlUp).Row)
Windows("Setting3.xlsm").Activate
LastRowThere() = Array(Sheets("Sheet1").Rows.Count, log()).End(xlUp).Row
For i = 1 To LastRowHere()
LastRowThere(1) = there.Sheets("Sheet1").Cells(Sheets("Sheet1").Rows.Count.log(1)).End(xlUp).Row
For k = 1 To LastRowThere()
'here.Sheets("Sheet1").Cells(i, k).Copy Destination:=there.Sheets("Sheet1").Cells(i, k)
here.Sheets("Sheet1").Rows(i).Columns(source(1)).Copy Destination:=there.Sheets("Sheet1").Rows(k + 1).Columns(log(1))
Next k
Next i
End Sub
Your problem is source().End(xlUp).Row. You're trying to use it as a range - which it's not. That is giving you the error.
You'd be better to populate your array by using a loop. And, unless you really want to carry the cell formatting across to the destination sheet, better not to use Copy since then you don't have to activate the destination sheet.
Not sure if the code below exactly fits your need. I wasn't sure of the purpose of log() array so I've left it out. The below copies the values of a single column from Source sheet to Destination sheet.
'Open both workbooks first:
Set here = Workbooks.Open("C:\Users\jesslynn\Desktop\macro\Setting2.xlsm")
Set there =Workbooks.Open("C:\Users\jesslynn\Desktop\macro\Setting3.xlsm")
SourceCol = 5 'Column E from your example
Set SourceSht = here.Sheets(1)
Set DestnSht = there.Sheets(1)
With SourceSht
'Get last cell in the column
LastRow = .Cells(.Rows.Count, SourceCol).End(xlUp).row
End With
With DestnSht
'Get last cell in the column
DestnLastRow = .Cells(.Rows.Count, SourceCol).End(xlUp).row
End With
'Loop through all cells (assumes row 1 is header)
For r = 2 to LastRow
'Assign value from Source to Destination sheet
i = i + 1
DestnSht.Cells(DestnLastRow + i, SourceCol) = SourceSht.Cells(r, SourceCol)
Next
Try this.
I assume you need copy the value from range E11 to E17 and J11 to J17
Option Explicit
Dim CurrentWorkbook As Workbook
Dim SourceWorkbook As Workbook
Dim DestWorkbook As Workbook
Dim CurrentWorksheet As Worksheet
Dim SourceWorksheet As Worksheet
Dim DestWorksheet As Worksheet
Sub setting2()
Dim SourceLastRow As Long
Dim DestLastRow As Long
Set CurrentWorkbook = ActiveWorkbook
Set CurrentWorksheet = CurrentWorkbook.ActiveSheet
Set SourceWorkbook = Workbooks.Open("C:\Users\lengkgan\Desktop\Testing\MyData1.xlsx") 'change to your path
Set DestWorkbook = Workbooks.Open("C:\Users\lengkgan\Desktop\Testing\MyTemplate.xlsx") 'change to your path
Set SourceWorksheet = SourceWorkbook.Sheets(1)
Set DestWorksheet = DestWorkbook.Sheets(1)
SourceLastRow = SourceWorksheet.Cells(Rows.Count, "E").End(xlUp).Row
DestLastRow = DestWorksheet.Cells(Rows.Count, "J").End(xlUp).Row + 1
SourceWorksheet.Range("E11:E17").Copy Destination:=DestWorksheet.Range("E" & DestLastRow + 1) 'Change to the column you want
SourceWorksheet.Range("J11:J17").Copy Destination:=DestWorksheet.Range("J" & DestLastRow + 1) 'Change to the column you want
End Sub
I have more than 50 files needed to create the pivot table and each file has the same exact formort with different contents. So far, I have finished creating the code for the pivot and it works very well when running alone, however, it failed when I tried to run the code for all workbooks in the same folder. I don't know what happened and why it kept showing that no files could be found despite nothing wrong about the pathname.
Sub DoAllFiles()
Dim Filename, Pathname As String
Dim WB As Workbook
Pathname = "D:\Reports"
Filename = Dir(Pathname & "\*.xls*")
Do While Filename <> ""
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Set WB = Workbooks.Open(Pathname & Filename) 'open all files
PivotX WB
WB.Close SaveChanges:=True
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Filename = Dir()
Loop
End Sub
Here is the code for pivot and it works very well when running it alone:
Sub PivotX(WB As Workbook)
Dim Lrow, Lcol As Long
Dim wsData As Worksheet
Dim rngRaw As Range
Dim PvtTabCache As PivotCache
Dim PvtTab As PivotTable
Dim wsPvtTab As Worksheet
Dim PvtFld As PivotField
Set wsData = ActiveSheet
Lrow = wsData.Cells(Rows.Count, "B").End(xlUp).Row
Lcol = wsData.Cells(1, Columns.Count).End(xlToLeft).Column
Set rngRaw = wsData.Range(Cells(1, 1), Cells(Lrow, Lcol))
Set wsPvtTab = Worksheets.Add
wsData.Select
ActiveWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:=rngRaw, Version:=xlPivotTableVersion12).CreatePivotTable TableDestination:=wsPvtTab.Range("A3"), TableName:="PivotTable1", DefaultVersion:=xlPivotTableVersion12
Set PvtTab = wsPvtTab.PivotTables("PivotTable1")
PvtTab.ManualUpdate = True
Set PvtFld = PvtTab.PivotFields("Month")
PvtFld.Orientation = xlPageField
PvtTab.PivotFields("Month").ClearAllFilters
Set PvtFld = PvtTab.PivotFields("Year")
PvtFld.Orientation = xlPageField
PvtTab.PivotFields("Year").ClearAllFilters
Set PvtFld = PvtTab.PivotFields("Fund_Code")
PvtFld.Orientation = xlRowField
PvtFld.Position = 1
Set PvtFld = PvtTab.PivotFields("Curr")
PvtFld.Orientation = xlColumnField
PvtFld.Position = 1
wsPvtTab.PivotTables("PivotTable1").PivotFields("Curr").PivotItems("USD").Position = 1
With PvtTab.PivotFields("Trx_Amount")
.Orientation = xlDataField
.Function = xlSum
.NumberFormat = "#,##0;[red](#,##0)"
End With
wsPvtTab.PivotTables("Pivottable1").RowAxisLayout xlTabularRow
'Remove grand total
wsPvtTab.PivotTables("Pivottable1").RowGrand = False
For Each PvtTbCache In ActiveWorkbook.PivotCaches
On Error Resume Next
PvtTbCache.Refresh
Next PvtTbCache
'Determine filter value
Set PvtFld = PvtTab.PivotFields("Year")
PvtFld.ClearAllFilters
PvtFld.EnableMultiplePageItems = True
With PvtFld
.AutoSort xlmnual, .SourceName
For Each Pi In PvtFld.PivotItems
Select Case Pi.Name
Case "2014"
Case Else
Pi.Visible = False
End Select
Next Pi
.AutoSort xlAscending, .SourceName
End With
'determine filter value
Set PvtFld = PvtTab.PivotFields("Month")
PvtFld.ClearAllFilters
PvtFld.EnableMultiplePageItems = True
With PvtFld
.AutoSort xlmnual, .SourceName
For Each Pi In PvtFld.PivotItems
Select Case Pi.Name
Case "11"
Case Else
Pi.Visible = False
End Select
Next Pi
.AutoSort xlAscending, .SourceName
End With
PvtTab.ManualUpdate = False
End Sub
Any help would be very much appreciated. Thank you very much in advance.
This should solve your problem:
Set WB = Workbooks.Open(Pathname & "\" & Filename)
When I tried using your code, for some reason, it did not retain the backslash you put at the beginning of the "Filename" variable. That would explain why VBA couldn't find the files. Adding it back should between the path name and file name should make it work correctly
I believe you have the answer to your base problem above but I would offer the following 'tweaks' to avoid screen flashing and unrecovered variable assignment.
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Do While Filename <> ""
Set WB = Workbooks.Open(Pathname & "\" & Filename) 'open all files
Call PivotX(WB)
WB.Close SaveChanges:=True
Set WB = Nothing
Filename = Dir()
Loop
Application.DisplayAlerts = True
Application.ScreenUpdating = True
The Set WB = Nothing is really only purposeful on the last pass when WB is not reassigned but your PivotX sub could use several Set nnn = Nothing before exiting. While the reference count is supposed to be decremented (and memory consequently released), that is not always the case. (see Is there a need to set Objects to Nothing inside VBA Functions) In short, it is just good coding practise.
Finally, using Dim Filename, Pathname As String declares Filename as a variant, not a string type. It isn't making any difference here but you should be aware of what your variables are being declared as.
I have a code for Excel 2007 that runs without failing.
But it is extremely & unusually slow - making my computer unresponsive for the 1-2 minutes it runs.
The files are about 14,000 kb's - so not too large.
If possible I'd like someone to tell me what I could do to make it run without causing my computer to hang. Thanks in advance.
Sub ReadFileIntoExcel()
Dim fPath As String
Const fsoForReading = 1
Dim readlength As Integer
Dim readstart As Integer
readlength = Worksheets("READFILE").Cells(1, "E").Value
readstart = Worksheets("READFILE").Cells(1, "D").Value
fPath = Worksheets("READFILE").Cells(1, "C").Value
Dim objFSO As Object
Dim objTextStream As Object, txt, allread, rw
Set objFSO = CreateObject("scripting.filesystemobject")
If objFSO.FileExists(fPath) Then
Set objTextStream = objFSO.OpenTextFile(fPath, fsoForReading)
rw = 1
Do Until objTextStream.AtEndOfStream
txt = objTextStream.ReadLine
allread = Trim(Mid(txt, readstart, readlength))
With ActiveWorkbook.Sheets("READFILE").Cells(rw, 7).Resize(1, 1)
.NumberFormat = "#" 'format cells as text
.Value = Array(allread)
End With
rw = rw + 1
Loop
objTextStream.Close
Set objTextStream = Nothing
Set objFSO = Nothing
Exit Sub
I updated your code to use an array rather than cell by cell wrote and it ran instantly
Optimisations made
Avoid cell range loops, especially writing cell by cell. Use arrays instead. This is the big one
Resize(1,1) does nothing as it keeps the cell as a single cell
Long is more efficient than Integer
Use the string functions Mid$ rather than their slower variant alternatives Mid
The allread variable was an un-necessary intermediate step
Using variable names for objects (ie ws for the worksheet), prevents longer references
code
Sub ReadFileIntoExcel()
Dim fPath As String
Dim ws As Worksheet
Const fsoForReading = 1
Dim readlength As Long
Dim readstart As Long
Dim rw as Long
Dim X()
Set ws = Worksheets("READFILE")
readlength = ws.Cells(1, "E").Value
readstart = ws.Cells(1, "D").Value
fPath = ws.Cells(1, "C").Value
Dim objFSO As Object
Dim objTextStream As Object
Set objFSO = CreateObject("scripting.filesystemobject")
If objFSO.FileExists(fPath) Then
Set objTextStream = objFSO.OpenTextFile(fPath, fsoForReading)
rw = 1
ReDim X(1 To 1, 1 To 1000)
Do Until objTextStream.AtEndOfStream
txt = objTextStream.ReadLine
If rw Mod 1000 = 0 Then ReDim Preserve X(1 To 1, 1 To UBound(X, 2) + 1000)
X(1, rw) = Trim$(Mid$(txt, readstart, readlength))
rw = rw + 1
Loop
ws.[G1].Resize(UBound(X, 2), 1) = Application.Transpose(X)
ws.Columns("G").NumberFormat = "#"
objTextStream.Close
Set objTextStream = Nothing
Set objFSO = Nothing
Exit Sub
End If
End Sub
You might try turning off screen updating while the cells are being updated. If you are touching a great many cells, this will definitely speed things up.
Application.ScreenUpdating = False
...update cells...
Application.ScreenUpdating = True
There are other things you can do as well, such as turning off calculations, but it doesn't sound like you have formulas trying to evaluate the cells your setting.