Excel VBA - copying data depending on column name - excel

I have a problem: using three separate worksheets (Source 1, Source 2, Template) I have to take data from the source files and paste it onto the Template, depending on the column names.
I.e. Source 1's first three columns' names match those on the Template, and the Template's fourth row matches the fourth row matches Source 2's fourth.
Here's what I got this far (it is incomplete).
Checking other threads I made a "derivation" of an example, but I still can not make it work. I get runtime error 9 on the line marked with a comment within Copy_Columns()
Sub MasterCopy()
Open_Files
Copy_Columns
End Sub
Sub Open_Files()
Application.Workbooks.Open Filename:="C:Source 1.xls"
Application.Workbooks.Open Filename:="C:Source 2.xls"
Application.Workbooks.Open Filename:="C:Template.xls"
End Sub
Sub Copy_Columns()
Dim Source1 As Worksheet
Source1 = Application.Workbooks("C:Source 1.xls").Worksheets("Sheet1") 'here is where the error appears
Source1.Select
Dim columnToBeCopied As Integer
columnToBeCopied = getColumnName("Source1", "columnToBeCopied")
Dim template As Worksheet
template = Application.Workbooks("C:Template.xls").Worksheets("Data")
template.Activate
Dim columnToBePasted As Integer
columnToBePasted = getColumnName("template", "columnToBePasted")
Sheets("Source1").Columns(columnToBeCopied).Copy Sheets("template").Columns(columnToBePasted)
End Sub
Public Function getColumnName(ByVal sheetName As String, ByVal columnName As String)
Dim lastColumn As Integer
lastColumn = ActiveSheet.Cells(Rows.Count, "A").End(xlUp).Column
Dim iterator As Integer
iterator = 0
While (iterator <= lastColumn)
If (LCase(Sheets(sheetName).Range(1, iterator)) = LCase(columnName)) Then
getColumnName = iterator
Else: iterator = iterator + 1
End If
Wend
If IsEmpty(getColumnName) Then getColumnName = 0
End Function
There's somewhat close examples but they are either too complex (this is my first time using VBA) or too "obscure" in terms that they use a, o, x, b as variable names...
Any help greatly appreciated :)

Change the line with the error to this:
Set Source1 = Workbooks("Source 1").Sheets("Sheet1")

Related

copy paste range after search

I inherited a report that acts as a master tracker for changes made in several other reports. The previous owner was using VLOOKUP formulas to pull data, however I decided to try my hand at a VBA macro and was able to patchwork something together (see below) despite being new to this. It works fine, however:
Problem 1: Right now, the macro returns values one column at a time. I have four nearly identical sub procedures that run back-to-back, one per column: Updated_LName (N), New_Doc (O), New_ID (P), Comments (Q).
Desired Solution: I'd like to increase efficiency by searching for the Student_ID_Nbr (K) in the previous worksheet and then returning values for all four columns at once: Updated_LName, New_Doc, New_ID, Comments (N:Q).
Problem 2: I couldn't figure out a better way than clearing formatting to skip to the next Student_ID_Nbr if it's not found on the previous page. I don't want to overwrite any existing values, which is why I didn't assign an empty string value in the If/Else statement.
Desired Solution: Find a better way to skip to the next iteration if Student_ID_Nbr is not found in the previous worksheet without overwriting existing data.
Problem 3: The macro currently ignores records where there is no Student_ID_Nbr match between the master and the previous worksheet. All changes must be extracted from the other reports and reflected in the master worksheet.
Desired Solution: I'd like to paste in the entire row (A:Q) for each record where the Updated_LName (N), New_Doc (O), New_ID (P), AND/OR Comments (Q) are not blank, AND the Student_ID_Nbr is not present in the master worksheet.
Note: Assume Student_ID_Nbr is a primary key.
Screenshot of example worksheets/data, after running macro successfully
K
L
M
N
O
P
Q
1
Imported
Imported
Imported
Imported
2
Student_ID_Nbr
Qty
LName
Updated_LName
New_Doc
New_ID
Comments
3
123456789
1
Doe
Smith
Transcript
987654321
Marriage cert submitted
Public Sub PullUpdated_LName()
'Declarations
Dim varID As Variant
Dim wsCurrent As Worksheet
Dim wsPrevious As Worksheet
Dim rngSelection As Range
Dim i As Integer
For i = 3 To 30000
'Initialization
Set wsCurrent = ActiveSheet
Set wsPrevious = wsCurrent.Previous
Set rngSelection = ActiveCell
'Error checking--do nothing if not in the correct column
If Not rngSelection.Column = 14 Then
MsgBox "Please select a cell in column N.", vbCritical + vbOKOnly, "Error"
Exit Sub
End If
'Search for ID on the previous ws
Set varID = wsPrevious.Columns(11).Find(What:=wsCurrent.Cells(rngSelection.Row, 11).Value)
'If ID not found, leave existing values alone (including empty cells) on current sheet
If varID Is Nothing Then
rngSelection.ClearFormats
Else
'Return the value in the appropriate row and column from the previous sheet
rngSelection.Value = wsPrevious.Cells(varID.Row, 14).Value
End If
'Regardless, move to the next cell
wsCurrent.Cells(rngSelection.Row + 1, rngSelection.Column).Select
Next i
'Move to next column (to prepare for the next sub)
wsCurrent.Cells(3, rngSelection.Column + 1).Select
'Run next sub automatically
PullNew_Doc
End Sub
Thank you to ShawnPCooke for the great starting point.
You seem to be re-initializing the worksheets each time around the loop, and the limit of 30000 rows to search seems arbitrary and will likely be slow while that searches empty space. Any time you "Select" a cell, you will potentially have the view updating; best to keep everything in Range variables.
This code probably addresses your first two points:
Public Sub Pull_All()
'Declarations
Dim varID As Variant
Dim wsCurrent As Worksheet
Dim wsPrevious As Worksheet
Dim rngSelection As Range
Dim i As Integer
Dim search_zone As Range
Dim last_row As Long
Dim update_cols As Variant
Dim ref_row As Long
Dim ref_col As Long
Dim col As Variant
update_cols = Array(14, 15, 16, 17)
ref_row = 3
ref_col = 11
'Initialize sheets
Set wsCurrent = ActiveSheet
Set wsPrevious = wsCurrent.Previous
Set search_zone = wsPrevious.Columns(11)
' start on a defined cell in the worksheet; this may need update
Set rngSelection = wsCurrent.Cells(ref_row, ref_col)
last_row = rngSelection.SpecialCells(xlCellTypeLastCell).Row
For i = ref_row To last_row
' Search for ID on the previous ws
Set varID = search_zone.Find(What:=rngSelection.Value)
If Not varID Is Nothing Then
' Return the values in the appropriate row and update columns from the previous sheet
For Each col In update_cols
rngSelection.Offset(0, col - ref_col).Value = wsPrevious.Cells(varID.Row, col).Value
Next col
End If
' move to the next cell
Set rngSelection = rngSelection.Offset(1, 0)
Next i
End Sub

Load Values From Closed Workbook Into Array

I have not used VBA in a while so I'm a bit rusty. Seeking help.
The task:
I need to pull all unique value from a given range in a closed workbook, into my sub's workbook.
I'm thinking of calling a function that returns an array of my unique non-blank values. because I need to know the quantity of unique values to insert the right amount of lines in the main workbook. Can't juts copy-paste the values. And also because I need to remove the duplicates.
Some relevant code bits up to know:
Sub PullACParts()
Dim FullFilePath As String
Dim arrPartList() As String
FullFilePath = "C:\Users\[...]file1.xlsx"
arrPartList() = GetValues(FullFilePath)
and that calls:
Function GetValues(path as string) as Variant
Dim arrValues() As String
Dim arrUnikVals As String
On Error GoTo ErrHandler
Application.ScreenUpdating = False
Dim src As Workbook
' OPEN THE SOURCE EXCEL WORKBOOK IN "READ ONLY MODE".
Set src = Workbooks.Open(FullFilePath, True, True)
' GET THE TOTAL ROWS FROM THE SOURCE WORKBOOK.
Dim iTotalRows As Integer
TotalRows = src.Worksheets("Sheet1").Range("D1:D" & Cells(Rows.Count, "D").End(xlUp).Row).Rows.Count
' COPY NON-BLANK DATA FROM SOURCE FILE COLUMN-4 TO ARRAY.
Dim iCnt As Integer ' COUNTER.
Dim ArrDim As Long: ArrDim = 0
For iCnt = 4 To TotalRows
If src.Worksheets("Sheet1").Range("D" & iCnt).Value <> "" Then
arrValues(ArrDim) = src.Worksheets("Sheet1").Cells(4 & iCnt).Formula 'FAILS HERE
ArrDim = ArrDim + 1
End If
Next iCnt
' CLOSE THE SOURCE FILE.
src.Close False ' FALSE - DON'T SAVE THE SOURCE FILE.
Set src = Nothing
' Remove Duplicates
arrUnikVals = RemoveDupesColl(arrValues)
GetValues = arrUnikVals
ErrHandler:
Application.EnableEvents = True
Application.ScreenUpdating = True
End Function
It fails when I try loading the array. Says "arrValues(ArrDim) =
I tried a few different things but just can't figure it out.
Thanks in advance for the help!!
You don't need to loop this. First set your variable types.
Dim arrValue as Variant, lr as long
Once this is a variant you can simply grab the array from the range in one go by transposing it:
lr = src.Worksheets("Sheet1").range("D" & rows.count).end(xlup).row
Application.transpose(src.Worksheets("Sheet1").range("D4:D" & lr))
If you need to loop the values in the array later you simply do something like this:
Dim X as long
For X = lbound(arrValue) to ubound(arrValue)
msgbox arrValue(X)
next
I do however note in your question you say you want to pull data from a CLOSED workbook but your code is opening the book. There are ways to pull data direct from a closed book but it would be difficult because you don't know how many rows it will be without opening the book. If you absolutely have to leave the book closed then post back.
I also note you are using cells(4 & iCnt) to try and populate the array, you do know that is just the cell counting from left to right then row to row? in other words cells(2) is B1 and cells(16386) is B2. You should use cells(Row,Column) I think from what you have said you want to increment the row but if not then post back, we simply double transpose if it's across columns instead of rows.

Return a column number based on the column name in csv file using .find

below is a piece of code that works on xlsx files but not on the csv files, at least I suspect so.
The aim of the code is to find a column name e.g. ProductType and return the column number in which the said column name is stored.
Again, this piece of code works perfectly when I run it on xslx file types, however doing so on the csv files does not work.
Any help is appreciated.
Sub ma1()
Dim RA As Excel.Workbook
Set RA = Workbooks.Open("G:\depts\Pri\RA.csv")
RA_col = RA.Sheets(1).Cells.Find(What:="ProductType", MatchCase:=True, LookAt:=xlWhole).Column
Debug.Print (RA_col)
End Sub
Instead of using find, if you only care about finding the column in the header row, you can simply iterate over the first row looking for a match. I've tried to encapsulate that into a function you can call.
You supply the filepath, ColumnName and optionally the type of comparison you want to perform. By default, the comparison is a case sensitive match (binary), but can also be swapped to a case insensitive match too.
Function
Option Explicit
Public Function GetColumnIndexFromFile(FilePath As String, ColumnName As String, Optional CompareMethod As VbCompareMethod = VbCompareMethod.vbBinaryCompare)
Dim wb As Workbook
Dim ws As Worksheet
Dim Column As Range
Dim Columns As Range
Dim ColumnIndex As Long
Set wb = Workbooks.Open(FilePath)
Set ws = wb.Sheets(1)
With ws
Set Columns = .Range(.Cells(1, 1), .Cells(1, .Cells(1, .Columns.Count).End(xlToLeft).Column))
End With
For Each Column In Columns
If StrComp(Column.Value2, ColumnName, CompareMethod) = 0 Then
GetColumnIndexFromFile = Column.Column
Exit Function
End If
Next
End Function
Example usage
Public Sub ExampleCall()
Debug.Print GetColumnIndexFromFile("G:\depts\Pri\RA.csv", "ProductType")
End Sub

VBA Copying data from one table to another and rearranging columns

I have 99 columns in one table called tbl_raw. I need to copy 96 of those columns into another table with the same exact header names, but they are rearranged in a different order. What is the most efficient way to do this?
The only way I knew was:
raw_data.Range("tbl_raw[EMPLOYEE]").Copy
processed_data.Range("tbl_processed[EMPLOYEE]").PasteSpecial
However, this would take a lot of code (96 * 2 = 192 lines) and I wasn't sure if there was a more efficient way to do it.
I tried to use https://www.thespreadsheetguru.com/blog/2014/6/20/the-vba-guide-to-listobject-excel-tables, but I couldn't figure out a way to do it with that information either.
Any guidance would be greatly appreciated.
Avoid dealing with copying ListObject columns and use a direct value transfer.
Option Explicit
Sub raw2processed()
Dim lc As Long, mc As Variant, x As Variant
Dim raw_data As Worksheet, processed_data As Worksheet
Dim raw_tbl As ListObject, processed_tbl As ListObject
Set raw_data = Worksheets("raw")
Set processed_data = Worksheets("processed")
Set raw_tbl = raw_data.ListObjects("tbl_raw")
Set processed_tbl = processed_data.ListObjects("tbl_processed")
With processed_tbl
'clear target table
On Error Resume Next
.DataBodyRange.Clear
.Resize .Range.Resize(raw_tbl.ListRows.Count + 1, .ListColumns.Count)
On Error GoTo 0
'loop through target header and collect columns from raw_tbl
For lc = 1 To .ListColumns.Count
Debug.Print .HeaderRowRange(lc)
mc = Application.Match(.HeaderRowRange(lc), raw_tbl.HeaderRowRange, 0)
If Not IsError(mc) Then
x = raw_tbl.ListColumns(mc).DataBodyRange.Value
.ListColumns(lc).DataBodyRange = x
End If
Next lc
End With
End Sub
Here's a basic example of copying over all but some columns from one table to another:
Dim tbl1 As ListObject, tbl2 As ListObject
Dim h As ListColumn
Set tbl1 = ActiveSheet.ListObjects("Table1")
Set tbl2 = ActiveSheet.ListObjects("Table2")
'loop over the headers from the source table
For Each h In tbl1.ListColumns
'is the column name in the "excluded" list?
If IsError(Application.Match(h.Name, Array("col10", "col11"), 0)) Then
'ok to copy...
h.DataBodyRange.Copy tbl2.ListColumns(h.Name).DataBodyRange(1)
End If
Next h
ForEach/For are the magic of working with arrays and collections.
There are ways to make the following code more efficient, but I think that may get in the way of understanding what is happening.
It has been about 6 months or so since I last worked with VBA, but I believe this should work. I suggest stepping through and watching your locals to see what is going on. If there are issues with variable assignments, there might need to be a 'Let' changed to a 'Set'.
Code follows:
'// PROBLEM:
'// Copy data from one list to a second list.
'// Both lists have the same column names and the same number of columns.
'// Copy data based on the column name.
'// Modify to return a custom source-destination association.
Private Function GetColumnTranslations(zLeftColumns As ListColumns, zRightColumns As ListColumns) As Variant
Dim zReturn(,) As Variant
ReDim zReturn(0 To zLeftColumns.Count As Long, 0 To 1 As Long)
Dim zReturnOffset As Long '// Specifies what index we are working at during our ForEach interations.
Dim zLeftVar As Variant
Dim zRightVar As Variant
ForEach zLeftVar in zLeftColumns
'// Go through each 'left' column to Find the first 'right' column that matches the name of the 'left' column.
'// Only the first 'right' column with a matching name will be used. Issue is solved with another ForEach, but beyond forum question's scope.
ForEach zRightVar in zRightColumns
If zLeftVar.Name = zRightVar.Name Then
'// Store the association and exit the nested ForEach.
Let zReturn(zReturnOffset, 0) = zLeftVar.Range.Column '// Source.
Let zReturn(zReturnOffset, 1) = zRightVar.Range.Column '// Destination.
Let zReturnOffset = zReturnOffset + 1
Exit ForEach
End If
Next zRightVar
Next zLeftVar
'// Assign return value.
Let GetColumnTranslations = zReturn
End Function
'// Take each source row and copy the value to a new destination row.
'// New rows are added to the end of the destination list.
Public Sub CopyList(zSourceList As ListObject, zDestinationList As ListObject)
Dim zColumnTranslations As Variant '// Will be 2-dimensional array.
Dim zTranslationVar As Variant '// Will be array of 2 elements.
Let zColumnTranslations = GetColumnTranslations(zSourceList.Columns, zDestinationList.Columns)
Dim zSourceRowVar As Variant '// Will translate to Range.
Dim zDestinationRow As Range
'// Every source row needs copied to a new row in destination.
ForEach zSourceRowVar in zSourceList.Rows
Set zDestinationRow = zDestinationList.Rows.Add.Range
ForEach zTranslationVar in zColumnTranslations
'// Value may copy formula.
Let zDestinationRow(0,zTranslationVar(1)).Value = zSourceRowVar(0,zTranslationVar(0)).Value
Next zTranslationVar
Next zSourceRowVar
End Sub

update multiple worksheets from a module with an absolute cell reference?

I'm in a module function, and I have a value that needs to get updated across multiple worksheets. I would like to take a data driven approach to this, since it may change a bit in the future.
In essence, I want to create an array of strings, each entry is an absolute reference to a cell, something like so:
Array("'Sheet1'!$A$1","'Sheet2'!$C$5")
I'd like to be able to do something like so
for each item in arr
Range(item).value = some_value
next item
The issue is that I'm in a module, The Range property is only available on a worksheet, and if I try to reference worksheet B from worksheet A via the Range property, it gives me an error.
How would you go about doing this?
Create an array of range objects like so:
arr = Array(WorkSheets("Sheet1").Range("A1"), WorkSheets("Sheet2").Range("C5"))
Dim rng as Range
For i = LBound(arr) To UBound(arr)
arr(i).Value = some_value
Next i
You could also use the Collection class
Dim coll As New Collection
Dim rng As Range
coll.Add WorkSheets("Sheet1").Range("A1")
coll.Add WorkSheets("Sheet2").Range("C5")
For Each rng In coll
rng.Value = some_value
Next rng
Given an array of string addresses, you can process it like
Sub Demo()
Dim arr As Variant
Dim sh As String, addr As String
Dim item As Variant
arr = Array("'Sheet 1'!$A$1", "'Sheet2'!$C$5")
For Each item In arr
sh = Replace(Left(item, InStr(item, "!") - 1), "'", "")
addr = Mid(item, InStr(item, "!") + 1)
Worksheets(sh).Range(addr) = some_value
Next
End Sub
If you can switch to an array (or collection) of Range then justnS' answer is better. But if you need to stick with an array of strings, this will do it.
You ask about multiple worksheets but say your program may be extended later. If it possible that you will need to update multiple workbooks, the following may be helpful.
I have set the array elements to workbook name, worksheet name, cell address and value. I have assumed the destination workbooks are open although it would not be difficult for the macro to open them if necessary. I test the workbook and worksheet names but not the cell address.
Sub Test1()
'
Dim Dest() As Variant
Dim DestPart() As String
Dim Found As Boolean
Dim InxBook As Integer
Dim InxDest As Integer
Dim InxSheet As Integer
Dest = Array("Test1.xls|Sheet3|B1|abc", "Test2.xls|Sheet2|F5|def", _
"Test3.xls|Sheet1|D3|ghi")
' Each element of Dest contains: workbook name, sheet name, cell address,
' and value separated by pipes.
' This code assumes the destination workbooks are already open.
For InxDest = LBound(Dest) To UBound(Dest)
DestPart = Split(Dest(InxDest), "|")
Found = False
For InxBook = 1 To Workbooks.Count
If DestPart(0) = Workbooks(InxBook).Name Then
Found = True
Exit For
End If
Next
If Found Then
With Workbooks(InxBook)
Found = False
For InxSheet = 1 To .Sheets.Count
If DestPart(1) = .Sheets(InxSheet).Name Then
Found = True
Exit For
End If
Next
If Found Then
.Sheets(InxSheet).Range(DestPart(2)).Value = DestPart(3)
End If
End With
End If
Next
End Sub

Resources