how to copy data based on a specific cell value from several workbooks into a master workbook - vba

I've have a problem where I need to copy data from 2 workbooks into a master one based on a specific set of values (several names) in a column 3. I'm new to VBA, and probably I can't precisely ask the question to find an answer, apologies for this. Would you please help me, i need to pull rows of data from each workbook only if a column 3 contains a name I'm looking for. I have the below code to pull the data from every workbook in a specific folder, however it grabs absolutely everything.
Sub copyDataFromManyFiles()
With Application
.DisplayAlerts = False
.EnableEvents = False
.ScreenUpdating = False
End With
Dim FolderPath As String, FilePath As String, FileName As String
FolderPath = "C:\Users\Jasiek\Desktop\Yuuuge MacroTest\"
FilePath = FolderPath & "*ennik*.xl*"
FileName = Dir(FilePath)
Dim lastrow As Long, lastcolumn As Long
Do While FileName <> ""
Workbooks.Open (FolderPath & FileName)
lastrow = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
lastcolumn = ActiveSheet.Cells(1, Columns.Count).End(xlToLeft).Column
Range(Cells(2, 1), Cells(lastrow, lastcolumn)).Copy
Application.DisplayAlerts = False
ActiveWorkbook.Close
erow = Sheet1.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
ActiveSheet.Paste Destination:=Worksheets(1).Range(Cells(erow, 1), Cells(erow, 30))
FileName = Dir
Loop
With Application
.DisplayAlerts = True
.EnableEvents = True
.ScreenUpdating = True
End With
'Call removeDuplicates
End Sub
How should I modify the code to filter the data before rows are copied? I do care about performance as there are 100k+ records. I would really appreciate help. Thanks.

Presuming that you're dealing with a fixed set of names (i.e.: 2-3) the easiest way to proceed would probably to use the instr() method to determine whether the cell value has a name that you're looking for.
If you're dealing with a larger list of names you could also just iterate through a collection (or array) of names for each row check. The instr() method below returns the integer position of the searched string from the string you're examining. If it finds something it will return some value greater than 0 for that position (i.e.: position 1 being the smallest value where it finds a match). The vbTextCompare option just ensures that it is case insensitive as it does the comparison (i.e.: upper or lower case mismatch).
I like to refer to worksheets and workbooks explicitly with my calls to ensure things are clean and specific, but you may be able to use ActiveWorkbook or ActiveWorksheet if you have a strong preference for it.
In terms of efficiency if you store each cell's value in a temporary string variable and just run the comparison against the tempStr string you will save retrieval time compared to referring to the cell value each time (which takes a much longer time to complete execution for x comparison checks for each row for x names).
Option Compare Text
Option Explicit
Public Sub start()
Dim foundBool As Boolean
Dim oxl As Excel.Application
Dim wb1 As Excel.Workbook
Dim tempName1 As String
Dim tempName2 As String
Dim tempStr1 As String
Dim tempStr2 As String
Dim tempInt1 As Integer
Dim tempInt2 As Integer
Set oxl = New Excel.Application
Set wb1 = oxl.Workbooks().Open("[path here]\Book1.xlsm")
wb1.Activate
'ActiveWorkbook.Worksheets ("") can also possibly be used
'if needed in lieu of a oxl and wb1 declaration, or perhaps
'even ActiveSheet.
'cells().value provides the apparent value of the cell taking formatting into account. Applies to things like dates
'or currencies where the underlying value might be different than what's shown.
tempStr1 = CStr(wb1.Worksheets("Sheet1").Cells(1, 1).Value)
tempName1 = "John"
'cells().value2 provides the underlying actual value of the cell (i.e.: without any formatting or interperetation).
'if you deal a lot with dates/currencies and don't want excel formatting to get between you and the source
'data use this one. Used here only to show the two different options
tempStr2 = CStr(wb1.Worksheets("Sheet1").Cells(2, 1).Value2) '<---next row's value
tempName2 = "Peter"
tempInt1 = InStr(1, tempStr1, tempName1, vbTextCompare)
tempInt2 = InStr(1, tempStr1, tempName2, vbTextCompare)
If tempInt1 > 0 Or _
tempInt2 > 0 Then
foundBool = True
End If
wb1.Close
oxl.Quit
Set wb1 = Nothing
Set oxl = Nothing
End Sub

Related

Optimize vba code when it comes to processing a high number of rows

Greeting all! I wrote a code that allows me to compare two EXCEL worksheets for same values; here it is:
Sub compare()
Dim i As Integer
Dim j As Integer
Dim oldVal1 As Variant
Dim oldVal2 As Variant
Dim newVal1 As Variant
Dim newVal2 As Variant
Dim count As Integer
Const equal = "equal"
Dim WKB As Workbook
Dim OldWS As Worksheet
Dim NewWS As Worksheet
Dim DiffWS As Worksheet
Const OldWSName = "Sheet1"
Const NewWSName = "Sheet2"
Const DiffWSName = "Sheet3"
Set WKB = ActiveWorkbook
Set OldWS = WKB.Worksheets(OldWSName)
Set NewWS = WKB.Worksheets(NewWSName)
Set DiffWS = WKB.Worksheets(DiffWSName)
Dim OldRow As Long
Dim NewRow As Long
Call OptimizeCode_Begin
oldRow = OldWS.Cells(Rows.Count, 1).End(xlUp).Row
newRow = NewWS.Cells(Rows.Count, 1).End(xlUp).Row
count = 1
For i = 2 To oldRow
oldVal1 = OldWS.Cells(i, 1).Value
oldVal2 = OldWS.Cells(i, 4).Value
For j = 2 To newRow
newVal1 = NewWS.Cells(j, 1).Value
newVal2 = NewWS.Cells(j, 4).Value
If (oldVal1 = newVal1) And (oldVal2 = newVal2) Then
count = count + 1
DiffWS.Cells(count, 1).Value = equal
DiffWS.Cells(count, 2).Value = oldVal1
DiffWS.Cells(count, 3).Value = oldVal2
End If
Next j
Next i
Call OptimizeCode_End
DiffWS.Activate
'Reset variables
Set WKB = Nothing
Set OldWS = Nothing
Set NewWS = Nothing
Set DiffWS = Nothing
Application.ScreenUpdating = True
MsgBox ("Your data has been compared!")
End Sub
This code is preceded by the variables definitions, long list that I chose not to paste in here. But basically, oldVal1 is the first value compared from OldWS worksheet and oldVal2 the second one from the same worksheet. Those values are being compared with newVal1 and newVal2 from NewWS worksheet (second worksheet). Same values are copied over to DiffWS (third worksheet) with an additional column on the left for the status equal, hence DiffWS.Cells(count + 1, 2).Value = oldVal1.
I've added the following functions to optimize the code and make it run fast when it comes to comparing 2 worksheets of at east 100000 rows:
Sub OptimizeCode_Begin()
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
EventState = Application.EnableEvents
Application.EnableEvents = False
PageBreakState = ActiveSheet.DisplayPageBreaks
ActiveSheet.DisplayPageBreaks = False
End Sub
AND
Sub OptimizeCode_End()
ActiveSheet.DisplayPageBreaks = PageBreakState
Application.EnableEvents = EventState
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
The execution is faster on a low number of rows I must admit, but it just doesn't work when the worksheets grow bigger. My EXCEL crashes when I run my code.
Any other optimization tips I should know of? because I am at loss as to how to do this. My code would be useless if no solution is available, and I'd better know it now and think about a way other than EXCEL to compare my data.
Thanks in advance for shedding light on this.
Your code sample doesn't indicate how you're opening each of the workbooks. In my experience, almost any time Excel crashes, it's because of a memory issue, and often that's because instances of Excel are being opened in the background, and then not .Close'd properly, or perhaps the excel objects not being Set to Nothing (perhaps from repeated execution of the code due to errors).
If this is the case, then Ctrl+Alt+Del → Task Manager → Processes will show multiple instances of Excel, and the easiest fix is to reboot, and then, of course, fix the handling of the Excel object in your code.
If the goal is to compare two worksheets, then perhaps a better question is why you are attempting to re-create functionality that already exists existing solutions available, most likely even built-in to your copy of Office.
Depending on your version, you may already have a utility installed.
For example, if you're running Office Pro Plus 2013, you can use Microsoft Spreadsheet Compare to run a report on the differences.
More information:
Basic tasks in Spreadsheet Compare
I'm running Excel 2016 from an Office 365 Subscription. I've never had a need to compare spreadsheets, but out of curiosity, I just:
Hit the Windows Key
Start typing: spreadsheet compare
Sit back and let the professionally built analysis/merge tool do it's job.
If all else fails, there are a number of other (3rd-Party) free and paid utilities available as well (such as xlCompare).

Excel loop macro ending early and needing to keep files open to copy several loops(different files)

I'm having a bit of a problem with this VBA code
Sub upONGOING_Train1()
ScreenUpdating = False
'set variables
Dim rFndCell As Range
Dim strData As String
Dim stFnd As String
Dim fCol As Integer
Dim oCol As Integer
Dim SH As Worksheet
Dim WS As Worksheet
Dim strFName As String
Dim objCell As Object
Set WS = ThisWorkbook.Sheets("Trains")
For Each objCell In WS.Range("L3:L100")
oCol = objCell.Column
strFName = WS.Cells(, oCol).Offset(objCell.Row - 1, 0)
On Error GoTo BLANK: 'skip macro if no train
Workbooks.Open Filename:=strFName 'open ongoing report
Set SH = Worksheets("Trains") 'set sheet
stFnd = WS.Cells(, oCol).Offset(objCell.Row - 1, 2).Value 'set connote
With SH
Set rFndCell = .Range("C3:C1100").Find(stFnd, LookIn:=xlValues)
If Not rFndCell Is Nothing Then
fCol = rFndCell.Column
WS.Cells(, oCol).Offset(objCell.Row - 1, 3).Resize(1, 6).Copy
SH.Cells(, fCol).Offset(rFndCell.Row - 1, 10).Resize(1, 6).PasteSpecial xlPasteValues 'paste values in ongoing report if connote found
ActiveWorkbook.Save 'save ongoing report
ActiveWorkbook.Close 'close ongoing report
Else 'Can't find the item
End If
End With
BLANK:
Next objCell
ScreenUpdating = True
End Sub
What I want it to do is - for every row in L3:L100
Open file listed in column "L" (if there or skip line to next one) and go to sheet
Match value from original sheet column "N" to "C3:C1100" in newly opened sheet
Copy columns "O:T" and paste relative to the matching value in the opened sheet(M:R) and save
However when I leave a gap of 2 rows it gives me the error for file not found instead of proceeding to the next loop like it does when there is only 1 row missing.
Seems i can't post images yet.
Also if anyone can point me in a good direction on how to open the sheet in the cell reference only if it is not already open it will usually only have 2 files to use (max of 4 at end of quarter).
Its just too much trouble to click OK on all the windows that pop up when you try to reopen an already open workbook.
If its any help to get your head around it.
I have 2 separate reports for 2 clients(new each quarter so max of 4 sheets at a time) that will already have the names to be searched (2 sheets in each book).
Any help would be greatly appreciated
Thanks heaps
Thanks to those who have put forth suggestions and code.
I'll them out tomorrow and failing that I've just come up with another idea that to re-purpose some other code I have but didn't realize would help.
The code basically copies what I need to a blank tab and deletes rows with a given value - with some formulas to help sort this would give me a block of rows with no breaks all going to the same destination file.
Thus allowing me to run the (a bit more streamlined Thanks everyone) loop over the remaining rows.
On Error GoTo BLANK
Workbooks.Open Filename:=strFName
Change the above into this:
On Error Resume Next
Workbooks.Open Filename:=strFName
If Err.Number <> 0 Then Goto Blank
As to hpw keep the workbook open, you can leave it open (no .close) but then when you want to open it check first if it is open (i.e. using Workbooks("name")), with some error handling using the same mechanism as above, if error exists then the wb is not already open, you open it.
Finally, avoid counting on the Active stuff, such as the ActiveWorkbook`. Instead, make an explicit reference to you wb, i.e.:
Set wb = Workbooks.Open(Filename:=strFName)
Set SH = wb.Worksheets("Trains")
to consider only not blank cells you can use SpecialCells() method of Range object and leave off any On Error GoTo statements, that should be used in very a few limited cases (one of which we'll see in a second)
furthermore you're using some uselessly long winded 'loops' to reference your relevant cells, for instance:
WS.Cells(, oCol).Offset(objCell.Row - 1, 0)
is equivalent to objCell itself!
and there are some more examples of that kind
finally, let's come to the workbooks open/close issue
you could:
use a Dictionary object to store the name of all opened workbooks so as to leave then open throughout your macro and close them all by the end of it
adopt a helper function that tries to set the wanted sheet (i.e. "Trains") in the wanted workbook (i.e. the one whose name is the current objCell value) and return False if not successful
all what above in this refactoring of your code:
Sub upONGOING_Train1bis()
Dim rFndCell As Range
Dim SH As Worksheet
Dim objCell As Range
Dim shtDict As New Scripting.Dictionary '<--| this is the dictionary that will store every opened workbook name as its 'keys'
Dim key As Variant
' Dim dec As String '<--| do you actually need it?
Application.ScreenUpdating = False
With ThisWorkbook.Sheets("Trains") '<-- reference your working worksheet
' dec = .Range("L1") '<-- what's this for? in any case take it out of for loops since its value doesn't depend on current loop variables
For Each objCell In .Range("L3:L100").SpecialCells(xlCellTypeConstants) '<--| loop through L3:L100 range not blank cells only
If TrySetWorksheet(objCell.Value, "Trains", SH) Then '<--|Try to set the wanted worksheet in the wanted workbook: if successful it'd retrun 'True' and leave you with 'SH' variable set to the wanted worksheet
shtDict(SH.Parent.Name) = shtDict(SH.Parent.Name) + 1
Set rFndCell = SH.Range("C3:C1100").Find(objCell.Offset(, 2).Value, LookIn:=xlValues, lookAt:=xlWhole) '<--| specify at least 'LookIn' and 'LookAt' parameters
If Not rFndCell Is Nothing Then rFndCell.Offset(, 10).Resize(, 6).Value = objCell.Offset(, 3).Resize(, 6).Value
End If
Next objCell
End With
For Each key In shtDict.Keys '<--|loop through opened workbooks dictionary keys
Workbooks(key).Close True '<--| close workbook whose name corresponds to current dictionary key
Next
Application.ScreenUpdating = True
End Sub
Function TrySetWorksheet(fileName As String, shtname As String, sht As Worksheet) As Boolean
Set sht = Nothing
On Error Resume Next
Set sht = Workbooks(Right(fileName, Len(fileName) - InStrRev(fileName, "\"))).Worksheets(shtname) '<--| try looking for an already open workbook with wanted name and wanted sheet
If sht Is Nothing Then Set sht = Workbooks.Open(fileName:=fileName).Worksheets(shtname) '<--| if not found then try opening the wanted workbook and set the wanted sheet in it
TrySetWorksheet = Not sht Is Nothing '<--| set the return value to the final result of attempts at locating the wanted sheet
End Function

VBA Move Data from workbooks to one specific workbook

I have files of sales data for each day from the last 5 years (hundreds of workbooks).
Each workbook has many worksheets, and I am looking to only take information from the summary sheet within each file.
Each file has a summary page titled "Summary Detailed" with:
4 pieces of data in cells E12, E13, E14, and E15.
I want to take this information and transpose it into rows in a new file.
I also want it to copy the name of the workbook into Column A and put the data next to it (columns B-E).
Then I would like to take two more pieces of data from another worksheet within those workbooks and place them in the columns to the right of the 4 above (F,G).
The other worksheet is called "Daily Detailed". Since the sales tally varies every day, the total number of rows is different in every file. But the two relevant rows are labeled "Total Pipes" and "Total Valves" (in Column B) and the data is located in the J column for both rows.
I have the files organized in folders by year, so "2014". Is it possible to run macro to open files within the folder without having to manually open each file?
Any ideas on how to build a macro to grab this data from each workbook?
Thanks!
The bare minimum of searching this site wouldve landed you something similar to this. Check out excel-vba documentation contents (its a pretty useful resource)>>
Sub Theloopofloops()
Dim wbk As Workbook
Dim Filename As String
Dim path As String
Dim rCell As Range
Dim rRng As Range
Dim wsO As Worksheet
Dim StartTime As Double
Dim SecondsElapsed As Double
Dim sheet As Worksheet
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.Calculation = xlCalculationManual
StartTime = Timer
path = "pathtofile(s)" & "\"
Filename = Dir(path & "*.xl??")
Set wsO = ThisWorkbook.Sheets("Sheet1")
Do While Len(Filename) > 0
DoEvents
Set wbk = Workbooks.Open(path & Filename, True, True)
For Each sheet In ActiveWorkbook.Worksheets
Set rRng = sheet.Range("b1:b308")
For Each rCell In rRng.Cells
If rCell <> "" And rCell.Value <> 0 Then
'code to do stuff
'avoid stuff like .copy/.paste
'using stuff like "sheet.range.value = sheet.range.value instead
End If
Next rCell
Next
wbk.Close False
Filename = Dir
Loop
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.Calculation = xlCalculationAutomatic
SecondsElapsed = Round(Timer - StartTime, 2)
MsgBox "This code ran successfully in " & SecondsElapsed & " seconds", vbInformation
End Sub
Also part of the requirements for asking questions on this site is having at least tried yourself. Seeing in how this code is readily available already in numerous places on this site, i saw no harm in just being helpful :)
Also youll need to adjust this code to suite your needs. I did the heavy lifting for you though.

Excel copy/paste data based on tab names in multiple files

I have a (hopefully) easy situation. I'm seeking to automate this process with a VBA macro.
I have an Excel spreadsheet (let's call this data.xls) that has multiple tabs with the following names (this is just an example):
Sucralose
Cellulose
Dextrose
Each tab simply has a column of data in it.
I want to know if there is a simple way to copy all the tabs of data to another spreadsheet with specific formatting for further operations (let's call this reduction.xls) based on the tab naming.
For example:
I want to copy Column A of tab Sucrose, Dextrose, Cellulose FROM data.xls TO Column F of the same named tabs (already existing) in reduction.xls [Sucrose, Dextrose, Cellulose].
I'm looking for a "true/false" type statement where the column from each tab in data.xls will be pasted into reduction.xls assuming the same exact named tab exists, without any need for interaction from the user.
Code posted below has the following features:
It is prepared for easily handling an arbitrary number of tabs. You have to modify only 3 lines, as indicated: 1) The list of tab names, 2) the name of the source workbook, 3) the name of the target workbook.
It is "protected" against missing tabs in the target workbook.
The structure is likely self-explanatory (although this might be a subjective statement).
.
Sub copy_tab(ByVal wsName As String)
Dim wbnamesrc As String
Dim wbnametrg As String
wbnamesrc = "source.xlsm" ' Change this line
wbnametrg = "Book8" ' Change this line
Dim wbsrc As Workbook
Dim wbtrg As Workbook
Set wbsrc = Workbooks(wbnamesrc)
Set wbtrg = Workbooks(wbnametrg)
If (WorksheetExists(wsName, wbnametrg)) Then
Dim rngsrc As Range
Dim rngtrg As Range
Application.CutCopyMode = False
wbsrc.Worksheets(wsName).Range("A:A").Copy
wbtrg.Worksheets(wsName).Range("A:A").PasteSpecial
End If
End Sub
Sub copy_tabs()
Dim wslist As String
Dim sep As String
wslist = "Sucralose|Cellulose|Dextrose|Sheet1" ' Change this line
sep = "|"
Dim wsnames() As String
wsnames = Split(wslist, sep, -1, vbBinaryCompare)
Dim wsName As String
Dim wsnamev As Variant
For Each wsnamev In wsnames
wsName = CStr(wsnamev)
Call copy_tab(wsName)
Next wsnamev
End Sub
Public Function str_split(str, sep, n) As String
' From http://superuser.com/questions/483419/how-to-split-a-string-based-on-in-ms-excel
' splits on your choice of character and returns the nth element of the split list.
Dim V() As String
V = Split(str, sep)
str_split = V(n - 1)
End Function
' From http://stackoverflow.com/a/11414255/2707864
Public Function WorksheetExists(ByVal wsName As String, ByVal wbName As String) As Boolean
Dim ws As Worksheet
Dim ret As Boolean
ret = False
wsName = UCase(wsName)
For Each ws In Workbooks(wbName).Worksheets
If UCase(ws.Name) = wsName Then
ret = True
Exit For
End If
Next
WorksheetExists = ret
End Function
Personally I would create the VBA in a separate workbook that you can open and execute separately from the other 2 interacting workbooks.
Thus I defined three dimension. wbk = workbook with code in it. wbk1 = the source workbook where you will copy from. wbk2 - the destination workbook where you will paste to.
You will have to edit the file locations as well as the Ranges. Say if you only wanted A1:A100, provided it is the same number of rows each time. If not I suggest increasing the rows far past what you anticipate the row count will be so you make sure you don't miss any.
Go to a new workbook
Hold Alt and press F11 key
Click Insert -> Module
Paste the below code in the window and update file locations and copy/paste range as needed
Press Run Macro (green play button) or hit F5 with your cursor in the code
Sub DataTransfer()
Dim wbk, wbk1, wbk2 As Workbook
'Workbook with VBA in it.
Set wbk = ActiveWorkbook
'Define destination workbook
Set wbk1 = Workbooks.Open("C:\data.xls")
'Define Source workbook
Set wbk2 = Workbooks.Open("C:\reduction.xls")
Call wbk1.Worksheets("Sucralose").Range("A1:A100000").Copy
Call wbk2.Worksheets("Sucralose").Range("F1:F100000").PasteSpecial(xlPasteValues)
Application.CutCopyMode = False
Call wbk1.Worksheets("Cellulose").Range("A1:A100000").Copy
Call wbk2.Worksheets("Cellulose").Range("F1:F100000").PasteSpecial(xlPasteValues)
Application.CutCopyMode = False
Call wbk1.Worksheets("Dextrose").Range("A1:A100000").Copy
Call wbk2.Worksheets("Dextrose").Range("F1:F100000").PasteSpecial(xlPasteValues)
Application.CutCopyMode = False
End Sub

Efficiently assign cell properties from an Excel Range to an array in VBA / VB.NET

In VBA / VB.NET you can assign Excel range values to an array for faster access / manipulation. Is there a way to efficiently assign other cell properties (e.g., top, left, width, height) to an array? I.e., I'd like to do something like:
Dim cellTops As Variant : cellTops = Application.ActiveSheet.UsedRange.Top
The code is part of a routine to programmatically check whether an image overlaps cells that are used in a workbook. My current method of iterating over the cells in the UsedRange is slow since it requires repeatedly polling for the top / left / width / height of the cells.
Update: I'm going to go ahead an accept Doug's answer as it does indeed work faster than naive iteration. In the end, I found that a non-naive iteration works faster for my purposes of detecting controls that overlap content-filled cells. The steps are basically:
(1) Find the interesting set of rows in the used range by looking at the tops and heights of the first cell in each row (my understanding is that all the cells in the row must have the same top and height, but not left and width)
(2) Iterate over the cells in the interesting rows and perform overlap detection using only the left and right positions of the cells.
The code for finding the interesting set of rows looks something like:
Dim feasible As Range = Nothing
For r% = 1 To used.Rows.Count
Dim rowTop% = used.Rows(r).Top
Dim rowBottom% = rowTop + used.Rows(r).Height
If rowTop <= objBottom AndAlso rowBottom >= objTop Then
If feasible Is Nothing Then
feasible = used.Rows(r)
Else
feasible = Application.Union(used.Rows(r), feasible)
End If
ElseIf rowTop > objBottom Then
Exit For
End If
Next r
Todd,
The best solution I could think of was to dump the tops into a range and then dump those range values into a variant array. As you said, the For Next (for 10,000 cells in my test) took a few seconds. So I created a function that returns the top of the cell that it's entered into.
The code below, is mainly a function that copies the usedrange of a sheet you pass to it and then enters the function described above into each cell of the usedrange of the copied sheet. It then transposes and dumps that range into a variant array.
It only takes a second or so for 10,000 cells. Don't know if it's useful, but it was an interesting question. If it is useful you could create a separate function for each property or pass the property you're looking for, or return four arrays(?)...
Option Explicit
Option Private Module
Sub test()
Dim tester As Variant
tester = GetCellProperties(ThisWorkbook.Worksheets(1))
MsgBox tester(LBound(tester), LBound(tester, 2))
MsgBox tester(UBound(tester), UBound(tester, 2))
End Sub
Function GetCellProperties(wsSourceWorksheet As Excel.Worksheet) As Variant
Dim wsTemp As Excel.Worksheet
Dim rngCopyOfUsedRange As Excel.Range
Dim i As Long
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
wsSourceWorksheet.Copy after:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count)
Set wsTemp = ActiveSheet
Set rngCopyOfUsedRange = wsTemp.UsedRange
rngCopyOfUsedRange.Formula = "=CellTop()"
wsTemp.Calculate
GetCellProperties = Application.WorksheetFunction.Transpose(rngCopyOfUsedRange)
Application.DisplayAlerts = False
wsTemp.Delete
Application.DisplayAlerts = True
Set wsTemp = Nothing
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Function
Function CellTop()
CellTop = Application.Caller.Top
End Function
Todd,
In answer to your request for a non-custom-UDF I can only offer a solution close to what you started with. It takes about 10 times as long for 10,000 cells. The difference is that your back to looping through cells.
I'm pushing my personal envelope here, so maybe somebody will have a way to to it without a custom UDF.
Function GetCellProperties2(wsSourceWorksheet As Excel.Worksheet) As Variant
Dim wsTemp As Excel.Worksheet
Dim rngCopyOfUsedRange As Excel.Range
Dim i As Long
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
wsSourceWorksheet.Copy after:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count)
Set wsTemp = ActiveSheet
Set rngCopyOfUsedRange = wsTemp.UsedRange
With rngCopyOfUsedRange
For i = 1 To .Cells.Count
.Cells(i).Value = wsSourceWorksheet.UsedRange.Cells(i).Top
Next i
End With
GetCellProperties2 = Application.WorksheetFunction.Transpose(rngCopyOfUsedRange)
Application.DisplayAlerts = False
wsTemp.Delete
Application.DisplayAlerts = True
Set wsTemp = Nothing
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Function
I would add to #Doug the following
Dim r as Range
Dim data() as Variant, i as Integer
Set r = Sheet1.Range("A2").Resize(100,1)
data = r.Value
' Alternatively initialize an empty array with
' ReDim data(1 to 100, 1 to 1)
For i=1 to 100
data(i,1) = ...
Next i
r.Value = data
which shows the basic process of getting a range into an array and back again.