Using a second Excel workbook as a table in VBA - excel

Wondering if it's possible to use a second workbook as a table to grab matching data similar to a vlookup without using the formula.
Example:
Workbook 1 I want to fill in Column R (Port Code) by looking at Column S (Port City) by using Workbook 2 which has a list of Cities in column D and the Port code I want to fill in workbook 1 in column A.
I know I could use a Vlookup but trying to avoid doing that if I can.
I was thinking of something like this but this only appears to look at the first line of the second worksheet. Any help or push in the right direction would be appreciated.
Dim lr As Long, lr1 As Long, i As Long
Dim LineMaster As Workbook
Dim ls As Worksheet
Dim di As Workbook
Dim td As Worksheet
Set td = di.Worksheets(1)
Set ls = LineMaster.Worksheets(1)
lr = ls.Range("I" & ls.Rows.Count).End(xlUp).Row
For i = 2 To lr
If ls.Range("S" & i).Value Like "" Then
ls.Range("R" & i).Value = ""
ElseIf ls.Range("N" & i).Value = Left(td.Range("D" & i).Value, 4) Then
ls.Range("N" & i).Value = td.Range("A" & i).Value
Else
End If
Next i

Not sure I completely understood your request, but I think you want to do a partial search. In this case, the Instr might be helpful.
I don't think using two workbooks is useful but let's do it your way. Here's what I would go with:
Sub PartialSearch()
Dim lr As Long, lr1 As Long, i As Long, j As Long
Dim lr2 As Long
Dim LineMaster As Workbook
Dim ls As Worksheet
Dim di As Workbook
Dim td As Worksheet
Set LineMaster = ThisWorkbook 'Workbook to fill
Set ls = LineMaster.Worksheets(1) 'Worksheet to fill
Set di = Workbooks.Open(your_workbook) 'Indicate the path of the workbook
Set td = di.Worksheets(1)
lr = ls.Range("S" & ls.Rows.Count).End(xlUp).Row 'Last row of the column S (where cities are already mentioned)
lr2 = td.Range("D" & di.Rows.Count).End(xlUp).Row
For i = 2 To lr
For j = 2 To lr2
If ls.Range("R" & i).Value = "" Then 'If the cell in column R is empty
If InStr(1, ls.Range("S" & i).Value, td.Range("D" & j).Value) > 0 Then 'Then the macro looks for a partial search in the other workbook
ls.Range("R" & i).Value = td.Range("A" & j).Value 'If the value is found, then the port code is written (change the column A if needed)
End If
End If
Next j
Next i
End Sub
Depending on the size of your workbook, this approach might not be the most effective. If it's too time consuming, you could go with .Find.

Related

How do I set a range of cell values to another range of cells in a different worksheet in VBA?

I have quite a few rows of inputs in the first worksheet. I am attempting to create a macro that loops through all of the rows by setting the values in a second worksheet equal to that of each row in the first. The second row runs the calculation and returns the outputs to the first worksheet. Nothing seems to happen when I run this. Any ideas?
Dim lRow As Integer
Dim rowStart As Integer
Dim i As Integer
rowStart = 7
lRow = Range("B1048576").End(xlUp).Row
For i = rowStart To lRow
Worksheets("CalcSheet").Range("C" & 5 & ":" & "Y" & 5) = Worksheets("DesignSheet").Range("C" & i & ":" & "Y" & i)
Worksheets("DesignSheet").Range("Z" & i & ":" & "AA" & i) = Worksheets("CalcSheet").Range("Z5:AA5")
Worksheets("DesignSheet").Range("AD" & i & ":" & "AE" & i) = Worksheets("CalcSheet").Range("AD5:AE5")
next i
Something like this is a bit more explicit in terms of what sheets are being referred to. Other comments in-line.
Sub Test()
Const ROW_START As Long = 7 'use Const for fixed values
Dim lRow As Long, i As Long 'use long instead of integer
Dim wsCalc As Worksheet, wsDes As Worksheet
'use worksheet variables and an explicit workbook object
Set wsCalc = ThisWorkbook.Worksheets("CalcSheet")
Set wsDes = ThisWorkbook.Worksheets("DesignSheet")
For i = ROW_START To wsDes.Cells(Rows.Count, "B").End(xlUp).row
With wsDes.Rows(i)
wsCalc.Range("C5:Y5").Value = .Range("C1:Y1").Value 'here C1:Y1 is *relative* to row i
wsCalc.Calculate 'to be sure...
.Range("Z1:AA1").Value = wsCalc.Range("Z5:AA5").Value
.Range("AD1:AE1").Value = wsCalc.Range("AD5:AE5").Value
End With
Next i
End Sub
A bit more about Range as used above...
Range() and Cells() are relative to the object they're called on, so
myWorksheet.Range("A1").Address '>> A1
myWorksheet.Range("B2:C3").Range("A1").Address '>> B2
So we're using wsCalc.Range() (fixed ranges) but moving the wsDes ranges by calling Range on wsDes.Rows(i)

Transferring Cell Values Between Worksheets | Str Looper

Intended Result
If a row in a table contains any of the listed strings in column L on Sheet1, Then copy the entire row from Sheet1 and paste the row into a duplicate table on Sheet2 (which would be blank at the beginning).
(UNINTERESTED, UNRELATED, UNDECIDED, etc...)
Then delete the entire row that was transferred from sheet 1.
After macro runs, the new transfers should not reset table on Sheet2, rather add rows on the pre-existing lines. This document would be utilized over months.
Variables
Sheet1 is named Pipeline_Input
Sheet2 is named Closed_Sheet
Sheet1 table is named tblData
Sheet2 table is named tblClosed
Images
Image 1 is the code with error
Image 2 is Sheet 1 with some picture explanation
Image 3 is Sheet 2 with some picture explanation
Current Result
Run-time error '1004':
Application-defined or object-defined error
Sub closedsheet()
Application.ScreenUpdating = False
Dim Pipeline_input As Worksheet 'where is the data copied from
Dim Closed_Sheet As Worksheet 'where is the data pasted to
Dim strPhase() As String
Dim i As Integer
Dim intPhaseMax As Integer
Dim lngLstRow As Long
Dim rngCell As Range
Dim finalrow As Integer
Dim lr As Long 'row counter
Dim Looper As Integer
intPhaseMax = 6
ReDim strPhase(1 To intPhaseMax)
strPhase(1) = "LOST"
strPhase(2) = "BAD"
strPhase(3) = "UNINTERESTED"
strPhase(4) = "UNRELATED"
strPhase(5) = "UNDECIDED"
strPhase(6) = "BUDGET"
'set variables
Set Pipeline_input = Sheet1
Set Closed_Sheet = Sheet2
lr = Range("A" & Rows.Count).End(xlUp).Row
For Looper = LBound(strPhase) To UBound(strPhase)
For i = lr To 6 Step -1
Next
If Not Sheet1.Range("L9:L300" & lngLstRow).Find(strPhase(Looper), lookat:=xlWhole) Is Nothing Then
Range(Cells(i, 1), Cells(i, 20)).Copy
Sheet2.Range("A" & Rows.Count).End(3)(2).PasteSpecial xlPasteValues
Range(Cells(i, 1), Cells(i, 20)).Delete
End If
Next
Sheet2.Select
Sheet2.columns.AutoFit
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub
Okay, there were a plethora of issues with the code you posted, but I decided to help you out here - Notice a few things - There's no copying and pasting here - we're just transferring data.
Secondly, use easy to understand variables. lr and lngLastRow can't be distinguished from one another, so classify them by which worksheet you're getting that value from.
We create an array in one fell swoop here - Just declare a variant and place our values in. ARRAYS (TYPICALLY) START AT ZERO, NOT ONE, so our loop starts at 0 :). Again, this is what's known as best practice...
I swapped out Looper for j. Again, keep. it. simple!
EDIT: I tested this code out on a simulated workbook and it worked fine - should run into no issues for you either.
EDIT2: Also, always use Option Explicit!
Option Explicit
Sub closedsheet()
Application.ScreenUpdating = False
Dim Pipeline_Input As Worksheet 'source sheet
Dim Closed_Sheet As Worksheet 'destination sheet
Dim i As Long, j As Long, CSlastrow As Long, PIlastrow As Long
Dim strPhase As Variant
'Here we create our array
strPhase = Array("LOST", "BAD", "UNINTERESTED", "UNRELATED", "UNDECIDED", "BUDGET")
'Assign worksheets
Set Pipeline_Input = ActiveWorkbook.Worksheets("Pipeline_Input")
Set Closed_Sheet = ActiveWorkbook.Worksheets("Closed_Sheet")
PIlastrow = Pipeline_Input.Range("A" & Rows.Count).End(xlUp).Row
For j = 0 To UBound(strPhase)
For i = PIlastrow To 6 Step -1
If Pipeline_Input.Range("L" & i).Value = strPhase(j) Then
'Refresh lastrow value
CSlastrow = Closed_Sheet.Range("A" & Rows.Count).End(xlUp).Row
'Transfer data
Closed_Sheet.Range("A" & CSlastrow + 1 & ":S" & CSlastrow + 1).Value = _
Pipeline_Input.Range("A" & i & ":S" & i).Value
'Delete the line
Pipeline_Input.Range("A" & i & ":S" & i).EntireRow.Delete
End If
Next i
Next j
Closed_Sheet.Select
Closed_Sheet.Columns.AutoFit
Application.ScreenUpdating = True
End Sub

Excel VBA offset function

I have an Excel file with information in column A and column B. Since these columns could vary in the number of rows I would like to use the function offset so that I could print the formula in one time as an array rather than looping over the formula per cell (the dataset contains almost 1 million datapoints).
My code is actually working the way I want it to be I only can't figure out how to print the code in Range(D1:D5). The outcome is now printed in Range(D1:H1). Anybody familiar how to use this offset within a for statement?
Sub checkOffset()
Dim example As Range
Dim sht As Worksheet
Dim LastRow As Long
Set sht = ThisWorkbook.Worksheets("Sheet1")
LastRow = sht.Cells(sht.Rows.Count, "A").End(xlUp).Row
Set example = Range("A1:A1")
For i = 1 To LastRow
example.Offset(0, i + 2).Formula = "=SUM(A" & i & ":B" & i & ")"
Next i
End Sub
Using the Offset(Row, Column), you want to offset with the increment of row (i -1), and 3 columns to the right (from column "A" to column "D")
Try the modified code below:
Set example = Range("A1")
For i = 1 To LastRow
example.Offset(i - 1, 3).Formula = "=SUM(A" & i & ":B" & i & ")"
Next i
One way of outputting the formula in one step, without looping, to the entire range, is to use the R1C1 notation:
Edit: Code modified to properly qualify worksheet references
Option Explicit
Sub checkOffset()
Dim example As Range
Dim sht As Worksheet
Dim LastRow As Long
Set sht = ThisWorkbook.Worksheets("Sheet1")
With sht
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
Set example = .Range(.Cells(1, 1), .Cells(LastRow, 1))
End With
example.Offset(columnoffset:=3).FormulaR1C1 = "=sum(rc[-3],rc[-2])"
End Sub
You don't need to use VBA for this. Simply type =sum(A1:B1) in cell D1 and then fill it down.
If you're going to use VBA anyway, use this:
Sub checkOffset()
Dim example As Range
Dim sht As Worksheet
Dim LastRow As Long
Set sht = ThisWorkbook.Worksheets("Sheet1")
LastRow = sht.Cells(sht.Rows.Count, "A").End(xlUp).Row
Set example = Range("A1:A1")
For i = 1 To LastRow
example.Offset(i - 1, 3).Formula = "=SUM(A" & i & ":B" & i & ")"
Next i
End Sub
The way offset works is with row offset, column offset. You want the column to always be fixed at 3 to the right.

How to append data to a column in a loop

My script takes data from multiple sheets and creates a new spreadsheet. The problem I am running into is how to append to the end of a column. I tried this:
LastRow = Sheets("Test").Cells(Rows.Count, "A").End(xlUp).Row
Where LastRow is defined as a long but I ran into an error when my loop continued going around. Here is what I have so far:
Sub autoFill()
Dim wb As Workbook, ws As Worksheet
Dim LastRow As Long
Dim Unit As String
Dim ddg As Variant, i As Variant
Set wb = ActiveWorkbook
Set ws = wb.Worksheets("Mapping")
ddg = ws.Range("F4:F21").Value
For Each i In ddg
Unit = "Unit #" & i
LastRow = Sheets("Test").Cells(Rows.Count, "A").End(xlUp).Row
Sheets(Unit).Range("A2:A100").Copy Destination:=Sheets("Test").Range("A1" & LastRow)
Sheets(Unit).Range("B2:B100").Copy Destination:=Sheets("Test").Range("B1" & LastRow)
Next i
End Sub
Just pick a range WAY above whatever the last row might be in whatever column will be populated (A in this case) when using xlUp. Add 1 to get to the next row:
LastRow = Sheets("Test").Range("A50000").End(xlUp).Row + 1
LAstRow now has a number that is equal to the first unused row in Column A of sheet Test.
Now concatenate that number to "A" to make a range like "A50". Right now you are doing:
Sheets(Unit).Range("A2:A100").Copy Destination:=Sheets("Test").Range("A1" & LastRow)
Which is concatenating the number to "A1" so you get "A150" which is nonsense... Instead:
Sheets(Unit).Range("A2:A100").Copy Destination:=Sheets("Test").Range("A" & LastRow)

Vba comparing then copying two different Sheets

I realize there are a few different similar ideas on here. But I need help with this simple compare function.
My goal is to compare two different cells and if they are the same, replace it with its full non-abbreviated name.
Thank you for your time!!!
I.E
Sheet1 Sheet2
Column H Column A Column B
Dept Dept Department
This is what I have (Yes simple), but the cell H is not updating to the non-abbreviation:
Sub updateDeptNames()
'Format user ID from the email column
Dim ws As Worksheet, ws2 As Worksheet
Dim LastRow As Long, i As Long
Dim tmpArray() As String, tempDept As String
Set ws = ActiveWorkbook.Sheets("Student_Travel_DB") '--> This is the relevant sheet
Set ws2 = ActiveWorkbook.Sheets("gokoutd") '--> This is the relevant sheet
LastRow = 1000 ''Bug finding the last row, had to hard code it
For i = 2 To LastRow 'Iterate through all the rows in the sheet
For j = 2 To 112
tempDept = ws2.Range("A" & j).Value
If ws.Range("H" & i).Value = tempDept Then
ws.Range("H" & i) = ws2.Range("B" & j).Value
End If
Next j
Next i
End Sub
You can more easily use VLOOKUP either on your worksheet or with VBA:
Sub GetFullName()
Dim cl As Range, data As Range, lookUpRng As Range
Set data = Worksheets("Student_Travel_DB").Range("A1:A10")
Set lookUpRng = Worksheets("gokoutd").Range("A1:B10")
On Error Resume Next
For Each cl In data
cl = WorksheetFunction.VLookup(cl, lookUpRng, 2, False)
Next cl
End Sub
You'll need to change your range references.

Resources