I have been trying to figure out how to merge two tables from the same workbook into a third one using VBA. Example :
Worksheet1:
From To Value
Italy Japan 1000
France Japan 500
Canada Japan 0
France Italy 700
Worksheet2:
From To Value
Italy Japan 5555
France Japan 1111
Canada Japan 777
Canada France 333
Disired output (worksheet3):
From To Value1 Value2
Italy Japan 1000 5555
France Japan 500 1111
Canada Japan 0 777
France Italy 700
Canada France 333
I would need a VBA solution since the original tables are about 400 rows long, and I would need to perform the same operation for several workbooks. I would be very grateful for any suggestion regarding this problem !
Edit:
In case it is of interest to anyone, I managed to make a working code. Worksheet1 was a nickname for "List Import" and Worksheet2 is "List Export". In both sheets, I inserted a column (C) that states both countries. I used that new column and the values to build the table in Worksheet3 (now "Combolist").
Sub combolist()
Dim lastRowImp As Long, lastRowExp As Long, startPaste As Long, endPaste As Long
Dim ws As Worksheet, Lookup_Range As Range, i As Integer
Dim lastRow As Long
lastRowImp = Sheets("List Import").Cells(Rows.Count, 1).End(xlUp).Row
lastRowExp = Sheets("List Export").Cells(Rows.Count, 1).End(xlUp).Row
startPaste = lastRowImp + 1
endPaste = lastRowImp + lastRowExp - 1
'add a new sheet and headers
Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = "Combolist"
Sheets("Combolist").Range("B1") = "Import"
Sheets("Combolist").Range("C1") = "Export"
Sheets("Combolist").Range("C1").EntireRow.Font.Bold = True
'copy flows from import and export list
Sheets("Combolist").Range("A1:A" & lastRowImp) = Sheets("List Import").Range("C1:C" & lastRowImp).Value
Sheets("Combolist").Range("A" & startPaste & ":A" & endPaste) = Sheets("List Export").Range("C2:C" & lastRowExp).Value
'remove duplicates
lastRow = Sheets("Combolist").Cells(Rows.Count, 1).End(xlUp).Row
Sheets("Combolist").Range(Cells(1, 1), Cells(lastRow, 1)).RemoveDuplicates Columns:=Array(1), Header:=xlYes
Set ws = ActiveWorkbook.Sheets("Combolist")
lastRow = Sheets("Combolist").Cells(Rows.Count, 1).End(xlUp).Row
'populate Import values
Set Lookup_Range = Sheets("List Import").Range("C1:D" & lastRowImp)
With ws
For i = 2 To lastRow
On Error Resume Next
If Application.WorksheetFunction.VLookup(ws.Cells(i, 1), Lookup_Range, 2, False) = "" Then
ws.Cells(i, 2) = 0
Else
ws.Cells(i, 2) = Application.WorksheetFunction.VLookup(ws.Cells(i, 1), Lookup_Range, 2, False)
End If
Next i
End With
'populate Export values
Set Lookup_Range = Sheets("List Export").Range("C1:D" & lastRowExp)
With ws
For i = 2 To lastRow
On Error Resume Next
If Application.WorksheetFunction.VLookup(ws.Cells(i, 1), Lookup_Range, 2, False) = "" Then
ws.Cells(i, 3) = 0
Else
ws.Cells(i, 3) = Application.WorksheetFunction.VLookup(ws.Cells(i, 1), Lookup_Range, 2, False)
End If
Next i
End With
End Sub
While this could be solved with VBA, you're likely to be better off using formulas (unless you must do this very frequently). The VBA solution will require some know-how, and even more if you want to be able to maintain the solution.
An Excel formula would be quite simple. First, create a UniqueID column:
UniqueID From To Value
Italy_Japan Italy Japan 1000
France_Japan France Japan 500
Canada_Japan Canada Japan 0
France_Italy France Italy 700
Canada_France Canada France
You would do the same thing for both tables. Next, get all of the unique UniqueID's. For this, you could use Data > Remove Duplicates, just be sure to make a copy before removing duplicates, otherwise you are removing records from your source. Put this list of UniqueID's into a new Table. Keep in mind that all of this will be easier if all of your data is in Table format (you'll see a Table tab in the ribbon when inside of the table range.
If you need to format your data as a table, go to the worksheet, press CTRL+HOME (this goes to the very first cell). If your first cell is in another location, just navigate there instead. If your table is the only data on the worksheet, try using CTRL+SHIFT+END from here to highlight to the last used cell. Otherwise, a combination of CTRL+SHIFT+RIGHT and CTRL+SHIFT+DOWN will get you what you need. Finally, name your table for the love of all that is excel, this one simple habit saves a ton of time. For my example I will assume that you have a Primary and Secondary table.
Our formula in our combined table would then look something like this:
=IfError(Vlookup([UniqueID], Primary, Column(Primary[Value]), False), "")
Or, if your Primary table doesn't start in the first column, use this:
=IfError(Vlookup([UniqueID], Primary, 4, False), "")
The difference here is that the former will change the index as the column is moved, the latter will not, and must be edited if the table is edited.
Do the same thing in your next column for the other table:
=IfError(Vlookup([UniqueID], Secondary, Column(Primary[Value]), False), "")
=IfError(Vlookup([UniqueID], Secondary, 4, False), "")
This will 'merge' the two sets based on the shared UniqueID and will leave blanks if the record doesn't exist. Learning how to do this may be less convenient than the learning how to do it in VBA, but I would strongly dissuade you from trying to learn VBA if you can't use an implementation like this.
To be clear, the reason why the formula approach is ideal in this instance is that the task you are asking for help with is very simple, and you would be better developing your Excel skills since, doing so, will allow you to solve similar tasks much faster in the future. Even a novice could implement this solution within 15 minutes or so, where it would easily take you days to learn a scalable VBA solution.
Related
Here is the problem I am trying to solve.
First I need to run an SQL query. This query returns data that has up to 12 categories, each dependent on the previous. For example, if my input into the query was 'United States', then column 1 would be 'United States', and column 2 would have each of the 50 states. Column three would then have all the major cities. So we end up with about 1000 rows, each with 'United States' on the left, a state in the middle, and the city that the state is on in the third column, like this:
United States Texas Austin
United States Utah Salt Lake City
United States Nevada Las Vegas
What I need to do is to programmatically create data validation for each of the categories based on the previous columns value.
My current idea is to take the original data, split it out into different sheets two columns at a time, and remove the duplicates. Then I would take the unique values from column A and paste them across the top, and distribute the data from column B into the correct columns. Then I'd make that a table, and make my data validation look at the headers in the table.
The problem comes in here: I don't know how to quickly distribute the data from column B into the correct column.
For clarity, this is what my data looks like on every page, except with thousands of pairs in columns A and B, and I need to distribute it into the three columns quickly.
Texas Utah Nevada
Texas Austin
Utah Salt Lake City
Nevada Las Vegas
Here's what I'm working with so far:
Num = 1
Col = 6
EndRow = Columns(Col).Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
For Col = 6 To 19
Set rng = Range(Cells(2, Col), Cells(EndRow, Col))
Unique = CountUnique(rng)
If Unique > 1 Then
Set rng2 = Sheets("SQL Dump").Range(Cells(2, Col), Cells(EndRow, Col + 1))
rng2.Copy
Set ws = Sheets.Add
ws.Name = "List" & Num
Num = Num + 1
ws.Activate
Cells(1, 1).PasteSpecial xlPasteAll
'MsgBox ("Do Stuff")
os.Activate
End If
Next Col
So that splits it into unique sheets as needed based on the two columns.
If anyone knows of a way to quickly sort, that would be greatly appreciated!
Or if you know a way to solve the problem more efficiently overall, I'd love to hear that, too--thanks!
EDIT: CountUnique is a function that I am using to count the number of Unique values that exist in a column.
This transposes ranges quite easily. is this what youre looking for?
Sub TransposeRangeValues()
Dim TmpArray() As Variant, FromRange As Range, ToRange As Range
Set FromRange = Sheets("Sheet1").Range("a1:c4")
Set ToRange = ThisWorkbook.Sheets("Sheet1").Range("a1")
TmpArray = Application.Transpose(FromRange.Value)
FromRange.Clear
ToRange.Resize(FromRange.Columns.Count, FromRange.Rows.Count).Value2 = TmpArray
End Sub
Background info: The aim of my tool is I have a form where when you enter a name in a cell and it brings up all of the details attached to that persons name using vlookups and basic excel code.
Now what I am doing is I would like to click a button and make vba run all the names through this tool so the details from the form are all stored in a table. The code below returns the first column of data from the first box in a For Each Loop (which this is doing fine if the second for loop is removed). The problem I have is I need a second for each loop to return a second column worth of data but the problem with this is the first for each loop only runs once and then it will run the second for each loop multiple times to return the second column of data that I need. What I need is either 1 for each loop which can take 2 ranges or a completely different way to do this. Any help would be much appreciated.
Public Sub Button1_Click()
Application.ScreenUpdating = True
Dim copySheet As Worksheet
Dim pasteSheet As Worksheet
Dim r As Range
Dim h As Range
Set copySheet = Worksheets("WIN RATES")
With copySheet
For Each r In .Range("H3", .Range("H" & Rows.Count).End(xlUp))
If Len(r) > 0 Then
Worksheets("NEW! FORM CHARTS").Range("E4").Value = r.Value
Worksheets("NEW! FORM CHARTS").Range("E4").Resize(, 1).Copy
Worksheets("Full Over 2.5 & BTTS list").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
Application.CutCopyMode = False
With copySheet
For Each h In .Range("N3", .Range("N" & Rows.Count).End(xlUp))
If Len(h) > 0 Then
Worksheets("NEW! FORM CHARTS").Range("M4").Value = h.Value
Worksheets("NEW! FORM CHARTS").Range("M4").Resize(, 1).Copy
Worksheets("Full Over 2.5 & BTTS list").Cells(Rows.Count, 2).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
Application.CutCopyMode = False
End If
Next h
End With
End If
Next r
End With
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub
The way I want it returned is like this:
Name 1 | Name 2
tom | 17846
mike | 16253
steve | 10987
Anne | 16243
But, understandingly, my data is doing this:
Name 1 | Name 2
tom | 17846
| 16253
| 10987
| 16243
The idea is that excel will run through all the names in the list and fill in the form with Name 1 and Name 2, together with these names input onto the form, they will fill in the rest of the form with the vlookups in the excel sheet itself, so my end goal is to have this kind of table where vlookup1 and vlookup2 is from the excel sheet:
Name 1 | Name 2 | VLOOKUPDATA1 | VLOOKUPDATA2
tom | 17846 | 1 | 80%
mike | 16253 | 8 | 90%
steve | 10987 | 6 | 23%
Anne | 16243 | 3 | 43%
I know this is long winded, just ask me if you need any clarification.
You don't need two loops, just the one acquiring data from columns "H" and "N" in each iteration. With that much data it'll take an awfully long time copying and pasting one cell at a time - you'd be far better reading to and writing from an array.
Code below shows both points. I really can't see why you're writing each item to the "NEW! FORM CHARTS" worksheet only to write over it with the next loop, so I've left that part out of your code. You'll see that there's a small bit of extra coding that just deals with the case that the two columns don't end on the same row.
I'd also recommend you read about classes as this will vastly simplify and probably speed up your tasks.
Dim home As Variant
Dim away As Variant
Dim r As Long, rMax As Long, rOffset As Long
Dim output() As Variant
With ThisWorkbook.Worksheets("WIN RATES")
home = .Range(.Range("H3").End(xlDown), .Range("H" & .Rows.Count).End(xlUp)).Value2
away = .Range(.Range("N3").End(xlDown), .Range("N" & .Rows.Count).End(xlUp)).Value2
End With
rMax = WorksheetFunction.Max(UBound(home, 1), UBound(away, 1))
ReDim output(1 To rMax, 1 To 2)
For r = 1 To rMax
If r <= UBound(home, 1) Then output(r, 1) = home(r, 1)
If r <= UBound(away, 1) Then output(r, 2) = away(r, 1)
Next
With ThisWorkbook.Worksheets("Full Over 2.5 & BTTS list")
rOffset = WorksheetFunction.Max(.Range("A1").End(xlUp).Row, .Range("A2").End(xlUp).Row)
.Range("A1").Offset(rOffset).Resize(UBound(output, 1), UBound(output, 2)).Value = output
End With
I have an Excel workbook I imported with 24,000 business names and addresses. I can't figure out how to separate them into different cells because no commas exist and the some businesses have multiple spaces in the name. Here is an example of what is in each column. Each line is in a separate row.
P & S DELI GROCERY 730 COLUMBUS AVENUE New York NY 10025
ANGELIKA FILM CENTER 18 WEST HOUSTON STREET New York NY 10012
SHASHEMENE INT'L RESTAURA 195 EAST 56 STREET New York NY 11203
CARVEL ICE CREAM 1006 EAST 233 STREET New York NY 10466
LEXLER DELI 405 LEXINGTON AVENUE New York NY 10174
SNACK TIME GRILL 87-69 LEFFERTS BOULEVARD New York NY 11418
MITCHEL LONDON FOODS 22 EAST 65 STREET New York NY 10065
SPOON BREAD CATERING 364 WEST 110 STREET New York NY 10025
TERMINAL CAFE/YANKEE CLIPPER 0 GUARDIA AIRPORT PARKING New York NY 11371
PLAZA BAGELS & DELI 73 NEW DORP PLAZA New York NY 10306
B & M HOT BAGEL & GROCERY 203 GIFFORDS LANE New York NY 10308
TEXAS ROTISSERIE 94 FULTON STREET New York NY 10038
One easy way to get going is to use the `Text to Columns function under the Data tab.
Highlight your cells that you want to split up, and click "Text to Columns". Choose a Delimiter, click "Next", then choose "Space".
Now, it'll take a word, put it in a cell, then take the next word (after a space), and put it in the cell next to that, etc.
The problem I forsee is this isn't going to be a one shot solution. As you mention, the restaurant names can be one word, of up to infinity words. Unless you see some logic in how it's spread out, I think this is your best bet.
For instance, is it safe to assume that if we are reading from left to right, and come across a number, that number starts the address and all preceding text is the restaurant name? ...I doubt it actually, what if my restaurant is called "Bruce's 21 Jump Street Eatery"? As #Johankr points out, this is probably more rare, but you should be aware of this possibility if you're just going to run the macro, save and close (without any human review). You could get a list of major cities, zip codes, etc. and use that to help parse through though and determine where the address starts/ends.
Copy it an paste into Google Spreadsheet and then use regular expressions (REGEXEXTRACT).
So for example to extract everything before the number use:
=REGEXEXTRACT(A1, "(\D*)\d")
It will extract P & S DELI GROCERY. Then to get the number use:
=REGEXEXTRACT(A1, "\D+(\d+)\D*")
It will get you 730. And so on...
This vba Should work for most of what you want:
Sub splitaddress()
Dim ws As Worksheet
Dim rng As Range
Dim oArr() As Variant
Dim lastrow As Long
Dim spltstr() As String
Dim i As Long
Dim j As Long
Dim h As Boolean
Set ws = Sheets("Sheet1")'Change to your sheet name.
lastrow = ws.Range("A" & ws.Rows.Count).End(xlUp).Row
ReDim oArr(1 To lastrow, 1 To 5)
j = 1
h = False
For Each rng In ws.Range("A1:A" & lastrow)
spltstr = Split(rng)
For i = LBound(spltstr) To UBound(spltstr)
If i = UBound(spltstr) Then
oArr(j, 5) = spltstr(i)
ElseIf i = UBound(spltstr) - 1 Then
oArr(j, 4) = spltstr(i)
ElseIf Not h And spltstr(i) = UCase(spltstr(i)) And InStr("1234567890", Left(spltstr(i), 1)) = 0 Then
oArr(j, 1) = oArr(j, 1) & spltstr(i) & " "
ElseIf InStr("1234567890", Left(spltstr(i), 1)) > 0 Or (h And spltstr(i) = UCase(spltstr(i))) Then
h = True
oArr(j, 2) = oArr(j, 2) & spltstr(i) & " "
ElseIf spltstr(i) <> UCase(spltstr(i)) Then
oArr(j, 3) = oArr(j, 3) & spltstr(i) & " "
End If
Next i
oArr(j, 1) = Trim(oArr(j, 1))
oArr(j, 2) = Trim(oArr(j, 2))
oArr(j, 3) = Trim(oArr(j, 3))
h = False
j = j + 1
Next rng
ws.Range("B1").Resize(lastrow, 5).Value = oArr
End Sub
If the street address does not start with a number it will not work.
If all the contacts only exists as a string, i.e. all data in the same cell, no solution is likely to be able to be able to split all contacts properly.
Here are some starting points though, all based on the assumption that the rest of the data looks fairly similar at least.
Very few business are likely to contain numbers in the names, so you can probably safely split address using the first occurance of a number as the divider between name and adress.
Create a lookup table for State and abbreviation. Should be possible to split the adress part of the string into two parts/lines using that.
Assumptions: The City is always = "New York"; the State is always =
"NY".
Place your data in column A starting at row 2.
In columns C thru L, at row 1, type numbers 0 to 9, where each column
gets 1 of the digits (0,1,2 ... 9).
Paste the following into cell C2:
=IF(TYPE(FIND(C$1,$A2,1))=16,LEN($A2),FIND(C$1,$A2,1))
Select and copy cell C2, select range D2:L2 and paste the copied
formula from cell B2.
Paste the following into cell B2: =MIN(C2:L2)
Paste the following into cell M2: =TRIM(MID(A2,1,B2-1))
Paste the following into cell N2: =TRIM(MID(A2,B2,FIND("New York_
NY",A2,1)-1-B2))
Type "New York" in cell O2.
Type "NY" in cell P2.
Paste the following into cell Q2: =RIGHT(A2,5)
Next select copy range B2:Q2 and paste it in rows B3 to end of your
data.
Not sure what the best way to describe this situation is, but I'll do my best. I am trying to create an import file for a database system using Excel.
Here is what we have as an example:
1) Names in a Column
2) Accounts in a Column (Accounts 1-3)
3) Amounts (An Amount for each Combo, ex: Name1, Account1, Name 1, Account2)
So what I want is an easy way (possibly with VBA?) to create an import file similar to below:
(Columns A, B, C)
Name#1, Account#1, Amount#1
Name#1, Account#2, Amount#2
Name#1, Account#3, Amount#3
Name#2, Account#1, Amount#4
Name#2, Account#2, Amount#5
etc.. etc..
Is there anyway to do this without having to do a ton of copying and pasting? I tried Pivot Tables, but it just doesn't seem to work for my situation
Sample Data:
Names | Accounts | Amounts
David 11230 $32.50
Marry 11240 $2.00
Jerry 54500 $990.00
64000 $500.00
$300.00
$600.00
$330.55
$500.00
$45.00
$53.38
$75.00
$44.00
Thus the intended output we want is:
David, 11230, $32.50
David, 11240, $2.00
David, 54500, $990.00
David, 64000, $500.00
Marry, 11230, $300.00
Marry, 11240, $600.00
....Continue...
Hope that helps
This worked for me:
Sub tester()
Dim sht As Worksheet, rngNames As Range, rngAccts As Range
Dim nm As Range, acct As Range, i As Long
Set sht = ActiveSheet
With sht
Set rngNames = .Range(.Range("A2"), _
.Cells(.Rows.Count, 1).End(xlUp))
Set rngAccts = .Range(.Range("B2"), _
.Cells(.Rows.Count, 2).End(xlUp))
End With
i = 1
For Each nm In rngNames.Cells
For Each acct In rngAccts.Cells
i = i + 1
sht.Cells(i, 5).Value = nm.Value
sht.Cells(i, 6).Value = acct.Value
sht.Cells(i, 7).Value = sht.Range("C1").Offset(i - 1, 0).Value
Next acct
Next nm
End Sub
Inputs are in ColA-C, output goes to Cols E-G
I have a spreadsheet (over 100,000 rows) with 10 columns of data. Two of the columns have comma separate value entries. I need a macro (or series of macros) or VBA script that can automatically duplicate the existing rows of data yet only have a single entry for each such comma separated value entry.
So today I have in a single row, columns A-D:
A B C D
John | Smith | Virginia | Apples, Bananas, Grapes, Mangoes
And I want:
A B C D
John | Smith | Virginia | Apples
John | Smith | Virginia | Bananas
John | Smith | Virginia | Grapes
John | Smith | Virginia | Mangoes
I need the macro to be "smart enough" to only create duplicate rows for the number of entries in the CSV cell. So, in my example, I had 4 fruit names. If I had 17 fruit names, I'd want 17 rows, each with a single instance of each fruit. If there are two identical fruit names, that's okay - I can live with two duplicate rows of the same exact fruit name.
Advice on how to accomplish this? I'm tried to parse text to columns but don't know enough about macro programming to do this.
For kicks, here it is with the de-duping
Converts data from A:D to E:H
Sub SliceNDice()
Dim objRegex As Object
Dim X
Dim Y
Dim lngRow As Long
Dim lngCnt As Long
Dim tempArr() As String
Dim strArr
Set objRegex = CreateObject("vbscript.regexp")
objRegex.Pattern = "^\s+(.+?)$"
'Define the range to be analysed
X = Range([a1], Cells(Rows.Count, "d").End(xlUp)).Value2
ReDim Y(1 To 4, 1 To 1000)
For lngRow = 1 To UBound(X, 1)
'Split each string by ","
tempArr = Split(X(lngRow, 4), ",")
For Each strArr In tempArr
lngCnt = lngCnt + 1
'Add another 1000 records to resorted array every 1000 records
If lngCnt Mod 1000 = 0 Then ReDim Preserve Y(1 To 4, 1 To lngCnt + 1000)
Y(1, lngCnt) = X(lngRow, 1)
Y(2, lngCnt) = X(lngRow, 2)
Y(3, lngCnt) = X(lngRow, 3)
Y(4, lngCnt) = objRegex.Replace(strArr, "$1")
Next
Next lngRow
'Dump the re-ordered range to columns E:H
[e1].Resize(lngCnt, 4).Value2 = Application.Transpose(Y)
ActiveSheet.Range("E:H").RemoveDuplicates Columns:=Array(1, 2, 3, 4), _
Header:=xlNo
End Sub
Not for points.
Since I have some time on my hands, I want to demo what the others above are saying. However, I'll add a little bit more. Note however, that #brettdj's code is much better than this, but at least this is quite simpler, if altogether not that equipped to solve 100,000 rows (that, I personally leave to you).
The logic:
We split the string using , as a delimiter. We store the result into an array.
We invoke a dictionary and use it to store unique values only. We trim the strings in the array as well.
We then use very simple movements to copy your row a number of times equal to the number of unique fruits now stored in our dictionary. This will give us enough space to post down our new list of fruits.
We transpose the dictionary contents into the resized original location.
Code:
Sub FruitNinja()
Dim FrootWhere As Range, Dict As Object
Dim Frooty As String, Froots() As String
Set FrootWhere = Range("D1")
Frooty = FrootWhere.Value
Froots = Split(Frooty, ",")
Set Dict = CreateObject("Scripting.Dictionary")
For i = LBound(Froots) To UBound(Froots)
If Not Dict.Exists(Froots(i)) Then
Dict.Add Trim(Froots(i)), Empty
End If
Next i
FrootWhere.EntireRow.Copy
Cells(FrootWhere.Row + 1, 1).Resize(Dict.Count - 1, 1).EntireRow.Insert
FrootWhere.Resize(Dict.Count, 1).Value = Application.Transpose(Dict.Keys)
Set FrootWhere = Nothing
Set Dict = Nothing
Application.CutCopyMode = False
End Sub
Set-up:
Result:
The concept of my approach is actually very simple. The way I'll do it given your data, if not using the better answer above, is to pass in a range to this sub, for how many relevant ranges you have. Basically, I'll be calling this from another sub.
The upside of this code is that it's pretty easy to check, debug, modify, and manipulate. The downside to this is that it'll be slow versus a large number of rows, it can be error prone in the weirdest of ways, and that it's hard to maintain versus a large number of conditions.
Hope this helps you. :)