I'm trying to figure out a problem in Excel. I am getting an Out of Memory error and I suspect that's not the problem but I don't really know.
Basically, I'm trying to make a macro that searches for a column within 5 tabs in a spreadsheet (the column can be in any of the 5 and it changes a lot) and when it finds it, does a vlookup match to return the column to the appropriate place in the master tab. Here is my code below which seems like it should work but I get the Out of Memory error. the line that is highlighted when I go to debug is the first Vrange = rB line in the if statement.
Dim i As Integer
Dim r As Range
'
Dim wsMaster As Worksheet: Set wsMaster = Workbooks("LBImportMacroTemplate.xlsm").Worksheets("MasterTab")
Dim wsB As Worksheet: Set wsB = Workbooks("LBImportMacroTemplate.xlsm").Worksheets("B")
Dim wsE As Worksheet: Set wsE = Workbooks("LBImportMacroTemplate.xlsm").Worksheets("E")
Dim wsL As Worksheet: Set wsL = Workbooks("LBImportMacroTemplate.xlsm").Worksheets("L")
Dim wsI As Worksheet: Set wsI = Workbooks("LBImportMacroTemplate.xlsm").Worksheets("I")
Dim wsT As Worksheet: Set wsT = Workbooks("LBImportMacroTemplate.xlsm").Worksheets("T")
'
Dim rBHeading As Range: Set rBHeading = wsB.Range("A2:ZA2")
Dim rEHeading As Range: Set rEHeading = wsE.Range("A2:ZA2")
Dim rLHeading As Range: Set rLHeading = wsL.Range("A2:ZA2")
Dim rIHeading As Range: Set rIHeading = wsI.Range("A2:ZA2")
Dim rTHeading As Range: Set rTHeading = wsT.Range("A2:ZA2")
'
Dim rB As Range: Set rB = wsB.Range("A:ZA")
Dim rE As Range: Set rE = wsE.Range("A:ZA")
Dim rL As Range: Set rL = wsL.Range("A:ZA")
Dim rI As Range: Set rI = wsI.Range("A:ZA")
Dim rT As Range: Set rT = wsT.Range("A:ZA")
'
Dim mf_iA_TEXT As String: mf_iA_TEXT = "iA"
'
If Application.CountIf(rBHeading, "iA") = 1 Then
Vrange = rB
Mrange = rBHeading
ElseIf Application.CountIf(rEHeading, "iA") = 1 Then
Vrange = rE
Mrange = rEHeading
ElseIf Application.CountIf(rLHeading, "iA") = 1 Then
Vrange = rL
Mrange = rLHeading
ElseIf Application.CountIf(rIHeading, "iA") = 1 Then
Vrange = rI
Mrange = rIHeading
Else
Vrange = rT
Mrange = rTHeading
End If
'
Dim mf_iA As Variant: mf_iA = Application.Match(mf_iA_TEXT, Mrange, 0)
'
With ActiveSheet
lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
MsgBox lastrow
End With
'
For i = 2 To lastrow
wsMaster.Cells(i, 2) = Application.VLookup(wsMaster.Cells(i, 1), Vrange, mf_iA, 0)
Next i
'
End Sub
I also tried to accomplish this with a case statement but I felt like I got further with the above code. If you could please let me know if this code is dumb, or if I can solve the Out of Memory error, I would greatly appreciate it. If I can get this to work, I will be copying the process with many many more columns, in case that matters. Thanks!!
To get you started, the first 56 lines of code could be written as,
Dim v As Long, vWSs As Variant, Mrange As Range, Vrange As Range, mf_iA as long
Dim wsMaster As Worksheet: Set wsMaster = Workbooks("LBImportMacroTemplate.xlsm").Worksheets("MasterTab")
Dim mf_iA_TEXT As String: mf_iA_TEXT = "iA"
vWSs = Array("B", "E", "L", "I", "T")
With Workbooks("LBImportMacroTemplate.xlsm")
mf_iA = 0: Set Mrange = Nothing: Set Vrange = Nothing
For v = LBound(vWSs) To UBound(vWSs)
If CBool(Application.CountIf(.Sheets(vWSs(v)).Range("A2:ZA2"), mf_iA_TEXT)) Then
Set Mrange = .Sheets(vWSs(v)).Range("A2:ZA2")
Set Vrange = .Sheets(vWSs(v)).Range("A:ZA")
' added the column number assignment on the next line
mf_iA = application.match(mf_iA_TEXT, Mrange, 0)
Exit For
End If
Next v
End With
if mf_iA = 0 then msgbox "Stop here! " & mf_iA_TEXT & "not found!"
'assumed that Mrange and Vrange are not nothing at this point
' and that mf_iA is the numerical column index number for mf_iA_TEXT
'do something with them
Set Mrange = Nothing
Set Vrange = Nothing
Set wsMaster = Nothing
That takes you to the end of the If/ElseIf/End If where you can continue processing. The last three are just reminders to manually set the ranges and workbook object to nothing after you are done with them.
Related
Thank you in advance, I need help in completing the below code, the code currently works to add the number of rows in the Table(3) of my word template as per the available rows in excel table, the word template have one row to begin with.
How can I pass the value from excel table range Set Rng = wsSheet.Range("A2:C" & lastrow)
Option Explicit
Sub CopyToWordTemplate()
Const stWordDocument As String = "TemplateSD.docm"
Dim intNoOfRows
Dim objWord As Word.Application
Dim objDoc As Word.Document
Dim wbBook As Workbook
Dim wsSheet As Worksheet
Dim lRow, i, lastrow, lastcol As Long
Dim vaData As Variant
Dim Rng As Range
Set wbBook = ThisWorkbook
Set wsSheet = wbBook.Worksheets("Transmittal")
lastrow = wsSheet.Range("A2").End(xlDown).Row
lastcol = wsSheet.Range("C2").End(xlToRight).Column
Set Rng = wsSheet.Range("A2:C" & lastrow)
Rng.ClearContents
Copy_Criteria_Text
lRow = wsSheet.Range("A2").End(xlDown).Row
intNoOfRows = lRow - 1
Set objWord = New Word.Application
objWord.Visible = True
Set objDoc = objWord.Documents.Open("\\Dn71\dn071\DOCUMENT CONTROL\Common\X-
Templates\Document Control\" & stWordDocument)
With objWord.ActiveDocument
.Bookmarks("Description").Range.Text = wsSheet.Range("D1").Value
.Bookmarks("RevNumber").Range.Text = "C" & wsSheet.Range("E1").Value
.Bookmarks("SubmittalNumber").Range.Text = "DN071-P02-CRC-GEN-PMT-SDA-" & wsSheet.Range("F1").Value
End With
For i = 2 To intNoOfRows
objDoc.Tables(3).Rows.Add
Next
Set objWord = Nothing
End Sub
I want to delete a row once I've copied it to another location. There are lots of posts for this issue; I'm not sure why none of them are working in my specific situation.
Sub Transition_Queue_to_Other()
Dim QueueSheet As Worksheet
Set QueueSheet = ThisWorkbook.Worksheets("Project Queue")
Dim TableQueue As ListObject
Set TableQueue = QueueSheet.ListObjects("TableQueue")
Dim TransColumn As Range
Set TransColumn = QueueSheet.Range("TableQueue[Transition]")
Dim Trans_Queue_Row As Range
Dim i As Integer
With TransColumn
For i = 1 To .Count
If InStr(1, .Rows(i).Value, "NPD") > 0 Then
Dim NPDSheet As Worksheet
Set NPDSheet = ThisWorkbook.Worksheets("NPD")
Dim TableNPD As ListObject
Set TableNPD = NPDSheet.ListObjects("TableNPD")
Set Trans_Queue_Row = TableQueue.DataBodyRange.Rows(i)
Set Trans_NPD_Row = TableNPD.ListRows.Add.Range
Trans_NPD_Row.Cells(, 1).Value = Trans_Queue_Row.Cells(, 2).Value
'Now, how do I delete each Trans_Queue_Row after I've copied the info from it to the Trans_NPD_Row? I've tried several different ways with no success, including:
'Trans_Queue_Row.Delete
'Trans_Queue_Row.Range.Delete
'Trans_Queue_Row.Select
'Selection.Delete
Try this Code:
Sub Transition_Queue_to_Other()
Dim QueueSheet As Worksheet
Set QueueSheet = ThisWorkbook.Worksheets("Project Queue")
Dim TableQueue As ListObject
Set TableQueue = QueueSheet.ListObjects("TableQueue")
Dim TransColumn As Range
Set TransColumn = QueueSheet.Range("TableQueue[Transition]")
Dim Trans_Queue_Row As Range
Dim i As Integer
Dim NPDSheet As Worksheet
Set NPDSheet = ThisWorkbook.Worksheets("NPD")
Dim TableNPD As ListObject
Set TableNPD = NPDSheet.ListObjects("TableNPD")
With TransColumn
For i = .Count To 1 Step -1
If InStr(1, .Rows(i).Value, "NPD") > 0 Then
Set Trans_Queue_Row = TableQueue.DataBodyRange.Rows(i)
Set Trans_NPD_Row = TableNPD.ListRows.Add.Range
Trans_NPD_Row.Cells(, 1).Value = Trans_Queue_Row.Cells(, 2).Value
Trans_Queue_Row.EntireRow.Delete xlShiftUp
End If
Next
End With
End Sub
Going from bottom to Up and deleting the Row using EntireRow.Delete
I am creating a macro that is supposed to separate and add new worksheets based off one worksheet with all the data in it.
It won't run and I'm not sure why.
My code keeps hitting a Run Time Error '9': Script out of range. I'm not sure if it has something to do with the first sub or the second sub.
The error occurs on line 16:
Set wsMain = wbMain.Sheets("MAIN")
First sub:
Option Explicit
Sub main()
Dim wbMain As Workbook
Dim wsMain As Worksheet
Dim rngMain As Range
Dim RngCategoryOne As Range
Dim RngCategoryTwo As Range
Dim RngCategoryThree As Range
Dim RngCategoryFour As Range
Dim RngCategoryFive As Range
Dim RngCategorySix As Range
Dim rng As Range
Dim SheetNames As Variant
Dim str As Variant
Set wbMain = ActiveWorkbook
Set wsMain = wbMain.Sheets("MAIN")
Set rngMain = wsMain.Range("F2:F3000")
For Each rng In rngMain
Select Case rng
Case "HO NMX_AMO", "HO NMX_EUR", "WTI NMX", "DIESEL OHR EIA_AMO"
If RngCategoryOne Is Nothing Then
Set RngCategoryOne = rng
Else
Set RngCategoryOne = Union(rng, RngCategoryOne)
End If
Case "WTI NMX_AMO"
If RngCategoryTwo Is Nothing Then
Set RngCategoryTwo = rng
Else
Set RngCategoryTwo = Union(rng, RngCategoryTwo)
End If
Case "NG HH NMX"
If RngCategoryThree Is Nothing Then
Set RngCategoryThree = rng
Else
Set RngCategoryThree = Union(rng, RngCategoryThree)
End If
Case "RBOB NMX_EUR", "RBOB NMX_AMO"
If RngCategoryFour Is Nothing Then
Set RngCategoryFour = rng
Else
Set RngCategoryFour = Union(rng, RngCategoryFour)
End If
Case "GO ICE_AMO"
If RngCategoryFive Is Nothing Then
Set RngCategoryFive = rng
Else
Set RngCategoryFive = Union(rng, RngCategoryFive)
End If
Case "C3 CONW INW OPIS_APO, C3 MBEL TET OPIS_APO"
If RngCategorySix Is Nothing Then
Set RngCategorySix = rng
Else
Set RngCategorySix = Union(rng, RngCategorySix)
SheetNames = Array("AT, LB, LC, AS", "AO", "LN", "RF, RA", "ULA2", "8K, BO")
For Each str In SheetNames
Call AddNewWorksheet(wbMain, str)
Next str
wbMain.Sheets("AT, LB, LC, AS").Range("A1:A" & RngCategoryOne.Count) = RngCategoryOne.Value
wbMain.Sheets("AO").Range("A1:A" & RngCategoryTwo.Count) = RngCategoryTwo.Value
wbMain.Sheets("LN").Range("A1:A" & RngCategoryThree.Count) = RngCategoryThree.Value
wbMain.Sheets("RF, RA").Range("A1:A" & RngCategoryFour.Count) = RngCategoryFour.Value
wbMain.Sheets("ULA2").Range("A1:A" & RngCategoryFive.Count) = RngCategoryFive.Value
wbMain.Sheets("8K, BO").Range("A1:A" & RngCategorySix.Count) = RngCategorySix.Value
wsMain.Activate
wsMain.Range("A1").Select
End If
End Select
Next
End Sub
Second Sub:
Sub AddNewWorksheet(ByRef wb As Workbook, ByVal wsName As Variant)
With wb.Sheets
.Add(after:=wb.Sheets(.Count)).Name = wsName
End With
End Sub
Am trying to programme a lookup across 2 workbook with workbook path and name linked to cell for dynamic updates ... my current code is getting an error:
"object does not support property or method" on line 29 set lookfor
Can you help me resolve this?
Sub Lookup()
Dim wb1 As String, wb2 As String
Dim wbook1 As Workbook, wbook2 As Workbook
Dim ws1 As Worksheet, ws2 As Worksheet
Dim lookFor As Range
Dim srchRange As Range
Dim wb1name As String, wb2name As String
Dim wb1path As String, wb2path As String
Dim sFormulaPre As String, sFormulaSuff As String
Dim rowstart As Long
wb1name = Workbooks("r.xlsm").Sheets("Front sheet").Range("B3").Text
wb2name = Workbooks("r.xlsm").Sheets("Front sheet").Range("AA1").Text
wb1path = Workbooks("r.xlsm").Sheets("Front sheet").Range("AB1").Text
wb2path = Workbooks("r.xlsm").Sheets("Front sheet").Range("AB1").Text
wb1 = wb1path & wb1name
wb2 = wb2path & wb1name
Set wbook1 = Workbooks(wb1name)
Set wbook2 = Workbooks(wb2name)
Set ws1 = wbook1.Sheets("DATA1")
Set ws2 = wbook2.Sheets("DATA")
Set lookFor = wbook2.ws2.Range("$G:$J")
Set srchRange = wbook1.ws1.Range("$A:$E")
Dim bIsEmpty As Boolean
sFormulaPre = "vlookup(D"
sFormulaSuff = ",srchRange, 2,FALSE)"
If IsEmpty(Workbooks("r.xlsm").Sheets("Front sheet").Range("Y1")) = False Then
With wbook2.ws2
rowstart = .Cells(G, 11)
MsgBox sFormulaPre & rowstart & sFormulaSuff
End With
ElseIf IsEmpty(Workbooks("Rates, percentages calculator.xlsm").Sheets("Front sheet").Range("Y1")) = True Then
bIsEmpty = True
End If
End Sub
You already Set your ws2 worksheet object to wbook2, with this line Set ws2 = wbook2.Sheets("DATA")
so change your :
Set lookFor = wbook2.ws2.Range("$G:$J")
to:
Set lookFor = ws2.Range("$G:$J")
The same goes for:
Set srchRange = wbook1.ws1.Range("$A:$E")
should be:
Set srchRange = ws1.Range("$A:$E")
And, change With wbook2.ws2
to: With ws2
I want to transfer information to a target workbook from a source workbook when the target sheet name is the source sheet name.
I am realtively new to VBA, have been working with it for 2 weeks now and have literally googled my a$$ off. This website has proven to be the best hulp so far.
I have to transpose much information on a standard basis to a different format, where I want to fI want to automate this by the following code:
Sub Transfer()
Dim wbt As Workbook, wbs As Workbook 'wbt = workbook target, wbs = workbooksource
Dim wst As Worksheet, wss As Worksheet 'wbt = worksheet target, wbs = worksheet source
Dim wkt As Integer, wks As Integer, wke As Integer 'wkt = number in target sheet name, wks = number in source sheet name, wke = number in sheet name after which I want to stop transferring information
Dim vFile As Variant
Dim CCT As Range, CCS As Range
Set wbt = ActiveWorkbook
vFile = Application.GetOpenFilename("Excel-files,*.xlsm", _
1, "Select One File To Open", , False)
If TypeName(vFile) = "Boolean" Then Exit Sub
Workbooks.Open vFile
Set wbs = ActiveWorkbook
wkt = 1
wks = 1
wke = 16
For Each wks In wbt.wst.("WK " & wkt)
If wks = wkt Then
wbt.wst("WK " & wkt).Range("K13:K63").Value = wbs.wss("WK " & wks).Range("G8:G58").Value
wbt.wst("WK " & wkt).Range("m13:m63").Value = wbs.wss("WK " & wks).Range("h8:h58").Value
wkt = wkt + 1
wks = wks + 1
If wke > wkt Then
wbs.Close (False)
Next
End Sub
This would be better already :
Sub Transfer()
Dim wbt As Workbook, wbs As Workbook 'wbt = workbook target, wbs = workbooksource
Dim wst As Worksheet, wss As Worksheet 'wbt = worksheet target, wbs = worksheet source
Dim wkt As Integer, wks As Integer, wke As Integer 'wkt = number in target sheet name, wks = number in source sheet name, wke = number in sheet name after which I want to stop transferring information
Dim vFile As Variant
Dim CCT As Range, CCS As Range
Set wbt = ActiveWorkbook
vFile = Application.GetOpenFilename("Excel-files,*.xlsm", _
1, "Select One File To Open", , False)
If TypeName(vFile) = "Boolean" Then Exit Sub
Set wbs = Workbooks.Open(vFile)
' wkt = 1
' wks = 1
wke = 16
For Each wss In wbs.Sheets
For Each wst In wbt.Sheets
If wst.Name <> wss.Name Or CInt(Replace(wss.Name, "WK ", "")) >= wke Then
Else
wst.Range("K13:K63").Value = wss.Range("G8:G58").Value
'wbt.wst("WK " & wkt).Range("m13:m63").Value = wbs.wss("WK " & wks).Range("h8:h58").Value
' wkt = wkt + 1
' wks = wks + 1
End If
' If wke > wkt Then wbs.Close (False)
Next wst
Next wss
wbs.Close
Set wbs = Nothing
Set wbt = Nothing
End Sub
I don't really get your "wke", it is a number in the sheetname on which you want to limit your copy? If it is, the code might be changed enough already.
Btw, the Set is kind of a way to create quicker references for later use in code but you can't add arguments in there and you have to free them at the end of your code, Set ... = Nothing
Thanks for the reseponses. I have actually found a way to make the code rune fluently. The completed code is:
Option Explicit
Sub Data_Transfer_Ur1_1_1_to_UR1_2()
Dim wbt As Workbook, wbs As Workbook
Dim wst As Worksheet, wss As Worksheet
Dim vFile As Variant
Dim CCT As Range, CCS As Range
Dim array1(1 To 53) As String
Dim og As Integer, bg As Integer
'Set source workbook
Set wbt = ActiveWorkbook
'Open the target workbook
vFile = Application.GetOpenFilename("Excel-files,*.xlsm", _
1, "Select One File To Open", , False)
'if the user didn't select a file, exit sub
If TypeName(vFile) = "Boolean" Then Exit Sub
Workbooks.Open vFile
'Set targetworkbook
Dim j As Integer
DataTransferUserForm.Show
og = DataTransferUserForm.InputBoxOG.Value
bg = DataTransferUserForm.InputBoxBG.Value
For j = og To bg
array1(j) = "WK " + CStr(j)
Next j
Set wbs = ActiveWorkbook
Dim i As Integer
For i = 1 To UBound(array1)
wbt.Worksheets(array1(i)).Range("K13:K63").Value = wbs.Worksheets(array1(i)).Range("G8:G58").Value
wbt.Worksheets(array1(i)).Range("m13:m63").Value = wbs.Worksheets(array1(i)).Range("h8:h58").Value
Set CCT = wbt.Worksheets(array1(i)).Range("O13")
For Each CCS In wbs.Worksheets(array1(i)).Range("J8:J58")
If CCS.Value > 0 Then
CCT.Value = "z"
CCT.Offset(0, 1).Value = CCS.Value
End If
Set CCT = CCT.Offset(1, 0)
Next
Set CCT = wbt.Worksheets(array1(i)).Range("O13")
For Each CCS In wbs.Worksheets(array1(i)).Range("K8:K58")
If CCS.Value > 0 Then
CCT.Value = "i"
CCT.Offset(0, 1).Value = CCS.Value
End If
Set CCT = CCT.Offset(1, 0)
Next
Set CCT = wbt.Worksheets(array1(i)).Range("O13")
For Each CCS In wbs.Worksheets(array1(i)).Range("L8:L58")
If CCS.Value > 0 Then
CCT.Value = "v"
CCT.Offset(0, 1).Value = CCS.Value
End If
Set CCT = CCT.Offset(1, 0)
Next
Set CCT = wbt.Worksheets(array1(i)).Range("O13")
For Each CCS In wbs.Worksheets(array1(i)).Range("m8:m58")
If CCS.Value > 0 Then
CCT.Value = "o"
CCT.Offset(0, 1).Value = CCS.Value
End If
Set CCT = CCT.Offset(1, 0)
Next
Set CCT = wbt.Worksheets(array1(i)).Range("O13")
For Each CCS In wbs.Worksheets(array1(i)).Range("n8:n58")
If CCS.Value > 0 Then
CCT.Value = "bv"
CCT.Offset(0, 1).Value = CCS.Value
End If
Set CCT = CCT.Offset(1, 0)
Next
wbt.Worksheets(array1(i)).Range("q13:q63").Value = wbs.Worksheets(array1(i)).Range("O8:O58").Value
wbt.Worksheets(array1(i)).Range("r13:r63").Value = wbs.Worksheets(array1(i)).Range("P8:P58").Value
Next i
wbs.Close (False)
wbt.Show