My questions is: How can I add multiple vLookup-formulas into one cell over VBA?
I know that I can add one vLookUp like this:
... = Application.WorksheetFunction.vLookUp("Search","Matrix","Index")
My Problem is: I have a workbook with 255 pages and in my "sum-sheet" I need variable formulas that search in those 255 worksheets for the data I need.
So the output of the macro in excel needs to be something like (all of in one cell):
=vLoookUp($A2;Sheet1!A1:A1000;2)+SVERWEIS($A2;Sheet2!A1:A1000;2)+ ...(255 times)
Is it even possible to do something like that with VBA?
This is the code I used to split the different options into the 255 sheets:
This is the code I wrote so far to split the different variations of stocks:
(Its somewhat working but I'm kind of sure its not very efficient, I'm new to all this Programming Stuff)
Sub Sheets()
Application.ScreenUpdating = False
ActiveWindow.WindowState = xlMinimized
Dim Data As String
Dim i As Long
Dim k As Long
Dim x As Long
Dim y As String
For i = 2 To 255
Sheetname = Worksheets("Input").Cells(i, 1).Value
Worksheets.Add.Name = Sheetname
ActiveSheet.Move After:=Worksheets(ActiveWorkbook.Sheets.Count)
x = 1
For k = 2 To 876
Data = Worksheets("Input").Cells(i, k).Value
y = Cells(1, x).Address(RowAbsolute:=False, ColumnAbsolute:=False)
BloomB = "=BDH(" & y & ",""TURNOVER"",""8/1/2011"",""4/30/2016"",""Dir=V"",""Dts=S"",""Sort=A"",""Quote=C"",""QtTyp=Y"",""Days=T"",""Per=cd"",""DtFmt=D"",""UseDPDF=Y"")"
Worksheets(Sheetname).Cells(1, x) = Data
Worksheets(Sheetname).Cells(2, x) = BloomB
x = x + 2
Next k
Application.Wait (Now + TimeValue("0:00:05"))
Next i
ActiveWindow.WindowState = xlMaximized
Application.ScreenUpdating = True
End Sub
Sorry, but this sounds like a very bad design. Maybe Access or SQL Server would be better suited for this kind of task. Also, you know the VLOOKUP function will return the first match, but no subsequent matches, right. Just want to make you aware of that. Ok, now try this.
Function VLOOKAllSheets(Look_Value As Variant, Tble_Array As Range, _
Col_num As Integer, Optional Range_look As Boolean)
''''''''''''''''''''''''''''''''''''''''''''''''
'Written by OzGrid.com
'Use VLOOKUP to Look across ALL Worksheets and stops _
at the first match found.
'''''''''''''''''''''''''''''''''''''''''''''''''
Dim wSheet As Worksheet
Dim vFound
On Error Resume Next
For Each wSheet In ActiveWorkbook.Worksheets
With wSheet
Set Tble_Array = .Range(Tble_Array.Address)
vFound = WorksheetFunction.VLookup _
(Look_Value, Tble_Array, _
Col_num, Range_look)
End With
If Not IsEmpty(vFound) Then Exit For
Next wSheet
Set Tble_Array = Nothing
VLOOKAllSheets = vFound
End Function
The full description of everything is here.
http://www.ozgrid.com/VBA/VlookupAllSheets.htm
Related
I've created a button on one workbook that opens another macro-less workbook. transposeDataMatrices is the sub that will be run on the worksheets in the workbook that is opened:
Private Sub CommandButton21_Click()
Set BEEBook = ThisWorkbook
FileSelect = Application.GetOpenFilename(FileFilter:="Excel Files (*.xl*), *.xl*", Title:="Please select the report to import")
If FileSelect = "False" Then Exit Sub
Set ReportBook = Workbooks.Open(FileSelect)
transposeDataMatrices
End Sub
Within transposeDataMatrices is the following, heavily truncated code (ReportBook is a global variable for the workbook being worked on in trasposeDataMatrices; cArray is a global array):
Public Sub transposeDataMatrices()
ReportBook.Activate
rowCounter = finWkst.UsedRange.Rows.Count
For ii = 1 To wsCount
Worksheets(ii).Activate
pullModelData (ii) ' just pulls some data, off ii worksheet in ReportBook
ReDim indexIDArray(0 To 504) As Integer
Dim j as Integer: j = 0
For Each catName In cArray
Dim totRange As Range
Set catTitle = Worksheets(ii).UsedRange.Find(catName)
If Not catTitle Is Nothing Then
catTitle.Offset(2, 0).Offset(0, 1).Select
ReportBook.Worksheets(ii).Range(Selection, Selection.End(xlToRight).Offset(0, -1)).Select
ReportBook.Worksheets(ii).Range(Selection, Selection.End(xlDown)).Select
Set totRange = Selection
Else
Set totRange = Cells("A1")
EndIf
indexIDArray(j) = j
Next
equipModelVersion rowCounter, indexIDArray
rowCounter = finWkst.UsedRange.Rows.Count
Next ii
End Sub
Sub equipModelVersion(rowCounterDummy As Integer, indexArrayDummy() As String)
ReportBook.Activate
finWkst.Activate
iCol = 1:
Set indexRange = Range(Cells(rowCounterDummy + 1, iCol), Cells(rowCounterDummy + 1 + UBound(valueArrayDummy, 1), iCol))
Dim j As Integer: j = 0
For I = rowCounterDummy + 1 To rowCounterDummy + 1 + UBound(valueArrayDummy, 1)
Cells(I, iCol) = indexArrayDummy(j)
j = j + 1
Next
End Sub
Sub initializeWorkspace()
ReportBook.Activate
finWkst.Activate
Range("A1").Value = "IndexID"
Range("B1").Value = "ModelID"
Range("C1").Value = "UserVersion"
Range("D1").Value = "Equipment"
Range("E1").Value = "Date"
For ii = LBound(cArray) To UBound(cArray)
Cells(1, ii + 5).Value = cArray(ii)
Next
End Sub
I have two questions:
Firstly, when equipModelVersion gets run, it stores the values in the cells of the workbook on the worksheet where the button is located, rather than the workbook that is opened, in a sheet created to store the values.
How do I rectify that?
I tried activating that specific worksheet, using a with statement, and some other quick things I found on Stack Overflow, but nothing worked.
Secondly, when I was debugging the transposeDataMatrices and had it separately, the following line worked:
Set totRange = Range(Range(Selection, Selection.End(xlToRight).Offset(0, -1)), Selection.End(xlDown))
In the macro that I transferred into the workbook with the button, it no longer works, so I had to work around it with:
ReportBook.Worksheets(ii).Range(Selection, Selection.End(xlToRight).Offset(0, -1)).Select
ReportBook.Worksheets(ii).Range(Selection, Selection.End(xlDown)).Select
Set totRange = Selection
Just looks bad.
Why is VBA being so dumb about it, when the code is EXACTLY IDENTICAL, but expanded?
VBA is not smart, it will only do what you tell it to do not what you think you told it to do.
My guess is that somewhere the ReportBook.Worksheets(ii) is losing focus.
It is good practice to always declare the parent when using objects. The easy way is to declare that parent object is as a variable.
in this case:
Dim ws as worksheet
set ws = ReportBook.Worksheets(ii)
then the with the two lines in question use a with statment
with ws
Set totRange =.Range(Selection, Selection.End(xlDown))
end with
You should avoid using the .select command. See here for great information on that. Using it only dirties the code and makes it harder to find the errors.
I have quite complex Excel VBA project with sheets containing multiple comments and validations and came over some wierd issue several days ago.
It happened that after adding some additional comments to the sheet validation.add stopped working properly showing comment shape for some random cell right after validation.add execution within the cell under validation.
After investigation and some tests I was able to replicate the issue on an empty worksheet with the following code:
Sub CommentsBug()
Dim rng As Range
Dim i As Long
Dim rngItem As Range
Set rng = ActiveSheet.Range("A1:C25000")
For Each rngItem In rng
rngItem.Cells(1, 1).Value = i
If rng.Comment Is Nothing Then rngItem.AddComment
rngItem.Comment.Text "Comment # " & i
i = i + 1
Next
ActiveSheet.Range("E1").Activate
ActiveCell.Validation.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:="1,2,3,4,5"
End Sub
After code execution I have comment box for a random cell appearing right within the validation cell (cannot put screenshot due to lack of rep).In case I change the last processed cell to C20000 the issue does not appear.
The system is Excel 2013 32-bit Office, Win 7 64.
I will be greatful for any advice and walkaround.
UPDATE AND QUICK FIX:
With the help of BruceWayne it was finally possible to get a quick fix (see below as approved answer). Somehow changing For Each statement to For and addressing separate cell ranges worked.
It really seems to be a bug, see important comments of John Coleman and BruceWayne on its specifics below. Hopefully someone from Microsoft will come across it, I have also posted issue at answers.microsoft.com.
As soon as I already had a worksheet full of data, the following comments update code worked for me in order to get rid of appearing comment box (takes amazingly outstanding amount of time for large sheets - many hours, put the number of your rows/columns instead of 3000/500 in the cycle, remove protect/unprotect statements in case you do not have cell protection):
Public Sub RestoreComments()
Dim i As Long
Dim j As Long
Dim rng As Range
Dim commentString As String
Application.ActiveSheet.Unprotect
Application.ScreenUpdating = False
For i = 1 To 3000
For j = 1 To 500
Set rng = Cells(i, j)
If Not rng.comment Is Nothing Then
commentString = rng.comment.Shape.TextFrame.Characters.Text
'commentString = GetStringFromExcelComment(rng.comment)
'see Update #2
rng.comment.Delete
rng.AddComment
rng.comment.Text commentString
rng.comment.Shape.TextFrame.AutoSize = True
End If
Next j
Next i
Application.ScreenUpdating = True
Application.ActiveSheet.Protect userinterfaceonly:=True
End Sub
UPDATE #2
When performing restoring comments I also came across another issue of trancation of comment string exceeding 255 characters when using comment.Shape.TextFrame.Characters.Text. In case you have long comments use the following code to return comment string:
'Addresses an Excel bug that returns only first 255 characters
'when performing comment.Shape.TextFrame.Characters.Text
Public Function GetStringFromExcelComment(comm As comment) As String
Dim ifContinueReading As Boolean
Dim finalStr As String, tempStr As String
Dim i As Long, commStrLimit As Long
ifContinueReading = True
commStrLimit = 255
i = 1
finalStr = ""
Do While ifContinueReading
'Error handling addresses situation
'when comment length is exactly the limit (255)
On Error GoTo EndRoutine
tempStr = comm.Shape.TextFrame.Characters(i, commStrLimit).Text
finalStr = finalStr + tempStr
If Len(tempStr) < commStrLimit Then
ifContinueReading = False
Else
i = i + commStrLimit
End If
Loop
EndRoutine: GetStringFromExcelComment = finalStr
End Function
The solution was found in the following thread (slightly changed to address the string exactly matching the limit):
Excel Comment truncated during reading
So, after tweaking the code, I found that if you change the For() loop, you can stop the comment from appearing. Try this:
Sub CommentsBug()
Dim rng As Range
Dim i As Long
Dim rngItem As Range
Dim ws As Worksheet
Dim k As Integer, x As Integer
Set ws = ActiveSheet
Application.ScreenUpdating = False
Set rng = ws.Range("A1:C25000")
For k = 1 To 25000
If i > 25000 Then Exit For
For x = 1 To 3
Set rngItem = Cells(k, x)
Cells(k, x).Value = i
If rng.Comment Is Nothing Then rngItem.AddComment
rngItem.Comment.Text "Comment # " & i
rngItem.Comment.Visible = False
rngItem.Comment.Shape.TextFrame.AutoSize = True
i = i + 1
Next x
Next k
ws.Range("E1").Validation.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:="1,2,3,4,5"
Application.ScreenUpdating = True
Application.DisplayCommentIndicator = xlCommentIndicatorOnly
End Sub
Note: This might take a little bit longer to run, but it doesn't give the same random comment popping up as yours does. Also, as for why this works and the other For() loop won't, I have no idea. I suspect it's something to do with the way Excel uses Validation, instead of it being something with the code (but that's pure speculation, perhaps someone else knows what is going on).
This kludge seems to work (although there is no guarantee that the underlying bug won't bubble to the surface somewhere else)
Sub CommentsBug()
Dim rng As Range
Dim i As Long
Dim rngItem As Range
Dim kludgeIndex As Long
Dim kludgeRange As Range
Dim temp As String
Application.ScreenUpdating = False
Set rng = ActiveSheet.Range("A1:C25000")
kludgeIndex = rng.Cells.Count Mod 65536
For Each rngItem In rng
rngItem.Cells(1, 1).Value = i
If i = kludgeIndex Then Set kludgeRange = rngItem
If rngItem.Comment Is Nothing Then rngItem.AddComment "Comment # " & i
i = i + 1
Next
Application.ScreenUpdating = True
ActiveSheet.Range("E1").Activate
ActiveCell.Validation.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:="1,2,3,4,5"
If Not kludgeRange Is Nothing Then
Debug.Print kludgeRange.Address 'in case you are curious
temp = kludgeRange.Comment.Text
kludgeRange.Comment.Delete
kludgeRange.AddComment temp
End If
End Sub
When run like above, kludgeRange is cell $C$3155 -- which displays 9464. If the 25000 is changed to 26000, kludgeRange becomes cell $C$4155, which displays 12464. This is a truly weird kludge where to exorcise the ghost from cell E1 you have to go thousands of cells away.
How do I code Excel VBA to retrieve the url/address of a hyperlink in a specific cell?
I am working on sheet2 of my workbook and it contains about 300 rows. Each rows have a unique hyperlink at column "AD". What I'm trying to go for is to loop on each blank cells in column "J" and change it's value from blank to the hyperlink URL of it's column "AD" cell. I am currently using this code:
do while....
NextToFill = Sheet2.Range("J1").End(xlDown).Offset(1).Address
On Error Resume Next
GetAddress = Sheet2.Range("AD" & Sheet2.Range(NextToFill).Row).Hyperlinks(1).Address
On Error GoTo 0
loop
Problem with the above code is it always get the address of the first hyperlink because the code is .Hyperlinks(1).Address. Is there anyway to get the hyperlink address by range address like maybe sheet1.range("AD32").Hyperlinks.Address?
This should work:
Dim r As Long, h As Hyperlink
For r = 1 To Range("AD1").End(xlDown).Row
For Each h In ActiveSheet.Hyperlinks
If Cells(r, "AD").Address = h.Range.Address Then
Cells(r, "J") = h.Address
End If
Next h
Next r
It's a bit confusing because Range.Address is totally different than Hyperlink.Address (which is your URL), declaring your types will help a lot. This is another case where putting "Option Explicit" at the top of modules would help.
Not sure why we make a big deal, the code is very simple
Sub ExtractURL()
Dim GetURL As String
For i = 3 To 500
If IsEmpty(Cells(i, 1)) = False Then
Sheets("Sheet2").Range("D" & i).Value =
Sheets("Sheet2").Range("A" & i).Hyperlinks(1).Address
End If
Next i
End Sub
My understanding from the comments is that you already have set the column J to a string of the URL. If so this simple script should do the job (It will hyperlink the cell to the address specified inside the cell, You can change the cell text if you wish by changing the textToDisplay option). If i misunderstood this and the string is in column AD simply work out the column number for AD and replace the following line:
fileLink = Cells(i, the number of column AD)
The script:
Sub AddHyperlink()
Dim fileLink As String
Application.ScreenUpdating = False
With ActiveSheet
lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
For i = 4 To lastrow
fileLink = Cells(i, 10)
.Hyperlinks.Add Anchor:=Cells(i, 10), _
Address:=fileLink, _
TextToDisplay:=fileLink
Next i
End With
Application.ScreenUpdating = True
End Sub
Try to run for each loop as below:
do while....
NextToFill = Sheet2.Range("J1").End(xlDown).Offset(1).Address
On Error Resume Next
**for each** lnk in Sheet2.Range("AD" & Sheet2.Range(NextToFill).Row).Hyperlinks
GetAddress=lnk.Address
next
On Error GoTo 0
loop
This IMO should be a function to return a string like so.
Public Sub TestHyperLink()
Dim CellRng As Range
Set CellRng = Range("B3")
Dim HyperLinkURLStr As String
HyperLinkURLStr = HyperLinkURLFromCell(CellRng)
Debug.Print HyperLinkURLStr
End Sub
Public Function HyperLinkURLFromCell(CellRng As Range) As String
HyperLinkURLFromCell = CStr(CellRng.Hyperlinks(1).Address)
End Function
I'm trying to link data from an Excel sheet, copy them to another sheet, and then copy onto another workbook. The data is non-contiguous, and the amount of iterations I need is unknown.
A portion of the code that I have now is below:
Sub GetCells()
Dim i As Integer, x As Integer, c As Integer
Dim test As Boolean
x = 0
i = 0
test = False
Do Until test = True
Windows("Room Checksums.xls").Activate
'This block gets the room name
Sheets("Sheet1").Activate
Range("B6").Select
ActiveCell.Offset(i, 0).Select
Selection.Copy
Sheets("Sheet2").Activate
Range("A1").Activate
ActiveCell.Offset(x, 0).Select
ActiveSheet.Paste Link:=True
'This block gets the area
Sheets("Sheet1").Activate
Range("AN99").Select
ActiveCell.Offset(i, 0).Select
Selection.Copy
Sheets("Sheet2").Activate
Range("B1").Activate
ActiveCell.Offset(x, 0).Select
ActiveSheet.Paste Link:=True
i = i + 108
x = x + 1
Sheets("Sheet1").Activate
Range("B6").Activate
ActiveCell.Offset(i, 0).Select
test = ActiveCell.Value = ""
Loop
Sheets("Sheet2").Activate
ActiveSheet.Range(Cells(1, 1), Cells(x, 12)).Select
Application.CutCopyMode = False
Selection.Copy
Windows("GetReference.xlsm").Activate
Range("A8").Select
ActiveSheet.Paste Link:=True
End Sub
The problem is that it is copying and pasting each cell one by one, flipping between sheets in the process. What I'd like to do is select a number of scattered cells, offset by 108 cells, and select the next number of scattered cells (re-sizing).
What would be the best way to do so?
I have been studying the end result of your macro. My objective is to identify a better approach to achieving that result rather than tidying your existing approach.
You name your two workbooks: "Room Checksums.xls" and "GetReference.xlsm". "xls" is the extension of an Excel 2003 workbook. "xlsm" is the extension of a post-2003 workbook that contains macros. Perhaps you are using these extensions correctly but you should check.
I use Excel 2003 so all my workbooks have an extension of "xls". I suspect you will need to change this.
I have created three workbooks: "Room Checksums.xls", "GetReference.xls" and "Macros.xls". "Room Checksums.xls" and "GetReference.xls" contain nothing but data. The macros are in "Macros.xls". I use this division when only privileged users can run the macros and I do not wish ordinary users to be bothered by or have access to those macros. My macro below can be placed without changes within "GetReference.xls" if you prefer.
The image below shows worksheet “Sheet1” of "Room Checksums.xls". I have hidden most of the rows and columns because they contain nothing relevant to your macro. I have set the cell values to their addresses for my convenience but there is no other significance to these values.
I ran your macro. “Sheet2” of "Room Checksums.xls" became:
Note: the formula bar shows cell A1 as =Sheet1!$B$6. That is, this is a link not a value.
The active worksheet of "GetReference.xls” became:
Note 1: the zeros in columns C to L are because you move 12 columns. I assume there is other data in these columns of “Sheet2” of your "Room Checksums.xls" that you want.
Note 2: the formula bar shows cell A8 as ='[Room Checksums.xls]Sheet2'!A1.
My macro achieves the same result as yours but in a somewhat different manner. However, there are a number of features to my macro which I need to explain. They are not strictly necessary but I believe they represent good practice.
Your macro contains a lot of what I call magic numbers. For example: B6, AN99, 108 and A8. It is possible that these values are meaningful to your company but I suspect they are accidents of the current workbooks. You use the value 108 several times. If this value were to change to 109, you would have to search your code for 108 and replace it by 109. The number 108 is sufficiently unusual for it to be unlikely that it occurs in your code for other reasons but other numbers may not be so unusual making replacement a painstaking task. At the moment you may know what this number means. Will you remember when you return to amend this macro in 12 months?
I have defined 108 as a constant:
Const Offset1 As Long = 108
I would prefer a better name but I do not know what this number is. You could replace all occurrences of “Offset1” with a more meaningful name. Alternatively, you could add comments explaining what it is. If the value becomes 109, one change to this statement fixes the problem. I think most of my names should be replaced with something more meaningful.
You assume "Room Checksums.xls" and "GetReference.xlsm" are open. If one of both of them were not open, the macro would stop on the relevant activate statement. Perhaps an earlier macro has opened these workbooks but I have added code to check that they are open.
My macro does not paste anything. It has three phases:
Work down worksheet “Sheet1” of "Room Checksums.xls" to identify last non-empty cell in the sequence: B6, B114, B222, B330, B438, ... .
Create links to these entries (and the AN99 series) in worksheet “Sheet2” of "Room Checksums.xls". Formulae are just strings which start with the symbol “=” and they can be created like any other string.
Create links in worksheet “Xxxxxx” of "GetReference.xls” to the table in “Sheet2” of "Room Checksums.xls". I do not like relying on the correct worksheet being active. You will have to replace “Xxxxxx” with the correct value.
In my macro I have attempted to explain what I am doing but I have not said much about the syntax of the statements I am using. You should have little difficulty finding explanations of the syntax but do ask if necessary.
I think you will find some of my statements confusing. For example:
.Cells(RowSrc2Crnt, Col1Src2).Value = "=" & WshtSrc1Name & "!$" & Col1Src1 & _
"$" & Row1Src1Start + OffsetCrnt
None of the names are as meaningful as I would like because I do not understand the purpose of the worksheets, columns and offset. Instead of copying and pasting, I am building a formula such as “=Sheet1!$B$6”. If you work through the expression you should be able to relate each term with an element of the formula:
"=" =
WshtSrc1Name Sheet1
"!$" !$
Col1Src1 B
"$" $
Row1Src1Start + OffsetCrnt 6
This macro is not quite as I would have coded it for myself since I prefer to use arrays rather than access worksheets directly. I decided that I was introducing more than enough concepts without the addition of arrays.
Even without arrays this macro is more difficult for a newbie to understand than I had expected when I started coding it. It is divided into three separate phases each with a separate purpose which should help a little. If you study it, I hope you can see why it would be easier to maintain if the format of the workbooks changed. If you have large volumes of data, this macro would be substantially faster than yours.
Option Explicit
Const ColDestStart As Long = 1
Const Col1Src1 As String = "B"
Const Col2Src1 As String = "AN"
Const Col1Src2 As String = "A"
Const Col2Src2 As String = "B"
Const ColSrc2Start As Long = 1
Const ColSrc2End As Long = 12
Const Offset1 As Long = 108
Const RowDestStart As Long = 8
Const Row1Src1Start As Long = 6
Const Row2Src1Start As Long = 99
Const RowSrc2Start As Long = 1
Const WbookDestName As String = "GetReference.xls"
Const WbookSrcName As String = "Room Checksums.xls"
Const WshtDestName As String = "Xxxxxx"
Const WshtSrc1Name As String = "Sheet1"
Const WshtSrc2Name As String = "Sheet2"
Sub GetCellsRevised()
Dim ColDestCrnt As Long
Dim ColSrc2Crnt As Long
Dim InxEntryCrnt As Long
Dim InxEntryMax As Long
Dim InxWbookCrnt As Long
Dim OffsetCrnt As Long
Dim OffsetMax As Long
Dim RowDestCrnt As Long
Dim RowSrc2Crnt As Long
Dim WbookDest As Workbook
Dim WbookSrc As Workbook
' Check the source and destination workbooks are open and create references to them.
Set WbookDest = Nothing
Set WbookSrc = Nothing
For InxWbookCrnt = 1 To Workbooks.Count
If Workbooks(InxWbookCrnt).Name = WbookDestName Then
Set WbookDest = Workbooks(InxWbookCrnt)
ElseIf Workbooks(InxWbookCrnt).Name = WbookSrcName Then
Set WbookSrc = Workbooks(InxWbookCrnt)
End If
Next
If WbookDest Is Nothing Then
Call MsgBox("I need workbook """ & WbookDestName & """ to be open", vbOKOnly)
Exit Sub
End If
If WbookSrc Is Nothing Then
Call MsgBox("I need workbook """ & WbookSrcName & """ to be open", vbOKOnly)
Exit Sub
End If
' Phase 1. Locate the last non-empty cell in the sequence: B6, B114, B222, ...
' within source worksheet 1
OffsetCrnt = 0
With WbookSrc.Worksheets(WshtSrc1Name)
Do While True
If .Cells(Row1Src1Start + OffsetCrnt, Col1Src1).Value = "" Then
Exit Do
End If
OffsetCrnt = OffsetCrnt + Offset1
Loop
End With
If OffsetCrnt = 0 Then
Call MsgBox("There is no data to reference", vbOKOnly)
Exit Sub
End If
OffsetMax = OffsetCrnt - Offset1
' Phase 2. Build table in source worksheet 2
RowSrc2Crnt = RowSrc2Start
With WbookSrc.Worksheets(WshtSrc2Name)
For OffsetCrnt = 0 To OffsetMax Step Offset1
.Cells(RowSrc2Crnt, Col1Src2).Value = "=" & WshtSrc1Name & "!$" & Col1Src1 & _
"$" & Row1Src1Start + OffsetCrnt
.Cells(RowSrc2Crnt, Col2Src2).Value = "=" & WshtSrc1Name & "!$" & Col2Src1 & _
"$" & Row2Src1Start + OffsetCrnt
RowSrc2Crnt = RowSrc2Crnt + 1
Next
End With
' Phase 3. Build table in destination worksheet
RowSrc2Crnt = RowSrc2Start
RowDestCrnt = RowDestStart
With WbookDest.Worksheets(WshtDestName)
For OffsetCrnt = 0 To OffsetMax Step Offset1
ColDestCrnt = ColDestStart
For ColSrc2Crnt = ColSrc2Start To ColSrc2End
.Cells(RowDestCrnt, ColDestCrnt).Value = _
"='[" & WbookSrcName & "]" & WshtSrc2Name & "'!" & _
ColNumToCode(ColSrc2Crnt) & RowSrc2Crnt
ColDestCrnt = ColDestCrnt + 1
Next
RowSrc2Crnt = RowSrc2Crnt + 1
RowDestCrnt = RowDestCrnt + 1
Next
End With
End Sub
Function ColNumToCode(ByVal ColNum As Long) As String
Dim Code As String
Dim PartNum As Long
' Last updated 3 Feb 12. Adapted to handle three character codes.
If ColNum = 0 Then
ColNumToCode = "0"
Else
Code = ""
Do While ColNum > 0
PartNum = (ColNum - 1) Mod 26
Code = Chr(65 + PartNum) & Code
ColNum = (ColNum - PartNum - 1) \ 26
Loop
End If
ColNumToCode = Code
End Function
I am using Microsoft Excel to keep track of tasks. I use a different "sheet" for each job. The structure is with regards to columns and data. I have been trying to create a VBA script that would accomplish the following:
Search sheets 1 - X for a value of "Open" or "Past Due" in a row
Copy all rows with those values into a single sheet (such as a ledger) starting at row 3 (so I can add the headers of the template)
Add a column A with the sheet name so that I know what job it came from.
Run this to my hearts obsessive compulsive behavior pleasure to update with new items
I have been using the following posts to help guide me:
Search a specific word and copy line to another Sheet <- which was helpful but not quite right...
Copying rows to another worksheet based on a search on a grid of tags <-- also helpful, but limited to the activesheet and not looping correctly with my modifications...
The last two evenings have been fun, but I feel like I may be making this harder than necessary.
I was able to create a VBA script (edited from another post here) to sweep through all the worksheets, but it was designed to copy all data in a set of columns. I tested that and it worked. I then merged the code base I was using to identify "Open" or "Past Due" in column C (that worked for only the activesheet) into the code. I marked up my edits to share here. At this point it is not functioning, and I have walked myself dizzy. Any tips on where I fubar-ed the code would be appreciated. My code base I working from is:
Sub SweepSheetsCopyAll()
Application.ScreenUpdating = False
'following variables for worksheet loop
Dim W As Worksheet, r As Single, i As Single
'added code below for finding the fixed values on the sheet
Dim lastLine As Long
Dim findWhat As String
Dim findWhat1 As String
Dim findWhat2 As String
Dim toCopy As Boolean
Dim cell As Range
Dim h As Long 'h replaced i variable from other code
Dim j As Long
'replace original findWhat value with new fixed value
findWhat = "Open"
'findWhat2 = "Past Due"
i = 4
For Each W In ThisWorkbook.Worksheets
If W.Name <> "Summary" Then
lastLine = ActiveSheet.UsedRange.Rows.Count 'Need to figure out way to loop all rows in a sheet to find last line
For r = 4 To lastLine 'formerly was "To W.Cells(Rows.Count, 1).End(xlUp).Row"
'insert below row match search copy function
For Each cell In Range("B1:L1").Offset(r - 1, 0)
If InStr(cell.Text, findWhat) <> 0 Then
toCopy = True
End If
Next
If toCopy = True Then
' original code Rows(r).Copy Destination:=Sheets(2).Rows(j)
Range(W.Cells(r, 1), W.Cells(r, 12)).Copy _
ThisWorkbook.Worksheets("Summary").Cells(i, 1)
j = j + 1
End If
toCopy = False
'Next
'end above row match search function
'below original code that copied everything from whole worksheet
' If W.Cells(r, 1) > 0 Then
' Range(W.Cells(r, 1), W.Cells(r, 12)).Copy _
' ThisWorkbook.Worksheets("Summary").Cells(i, 1)
' i = i + 1
' End If
Next r
End If
Next W
End Sub
The working code base to sweep through all the sheets was:
Sub GetParts()
Application.ScreenUpdating = False
Dim W As Worksheet, r As Single, i As Single
i = 4
For Each W In ThisWorkbook.Worksheets
If W.Name <> "Summary" Then
For r = 4 To W.Cells(Rows.Count, 1).End(xlUp).Row
If W.Cells(r, 1) > 0 Then
Range(W.Cells(r, 1), W.Cells(r, 3)).Copy _
ThisWorkbook.Worksheets("Summary").Cells(i, 1)
i = i + 1
End If
Next r
End If
Next W
End Sub
And the copy the matched data from the Activesheet is as follows:
Sub customcopy()
Application.ScreenUpdating = False
Dim lastLine As Long
Dim findWhat As String
Dim findWhat1 As String
Dim findWhat2 As String
Dim toCopy As Boolean
Dim cell As Range
Dim i As Long
Dim j As Long
'replace original findWhat value with new fixed value
findWhat = "Open"
'findWhat2 = "Past Due"
lastLine = ActiveSheet.UsedRange.Rows.Count 'Need to figure out way to loop through all sheets here
'below code does nice job finding all findWhat and copying over to spreadsheet2
j = 1
For i = 1 To lastLine
For Each cell In Range("B1:L1").Offset(i - 1, 0)
If InStr(cell.Text, findWhat) <> 0 Then
toCopy = True
End If
Next
If toCopy = True Then
Rows(i).Copy Destination:=Sheets(2).Rows(j)
j = j + 1
End If
toCopy = False
Next
i = MsgBox(((j - 1) & " row(s) were copied!"), vbOKOnly, "Result")
Application.ScreenUpdating = True
End Sub
You should look into this Vba macro to copy row from table if value in table meets condition
In your case, you would need to create a loop, using this advanced filter to copy the data to your target range or array.
If you need further advice, please post your code, and where you are stuck with it.