Simple Data Sort & Merge Code.

DocAElstein

DocAElstein

Banned user
Joined
May 24, 2014
Messages
1,336
Simple Data Sort & Merge Code. ​

Hi,
. I don’t have a specific problem, but am just looking for alternative (Better?) methods of achieving something:-
. I am still very new (that is to say a very late starter!) to Programming. I am creating one massive Main data File. That involves bringing in data typically in simple tables from various sources, such as Internet sites. The format from these tables is always a bit different, or uses different names or spellings for the same quantities. To speed this up a bit I use VBA to bring the data into the correct place in the main file. .
. The following code, (first Abbreviated without comments), demonstrates my technique):-


<font face=Calibri><SPAN style="color:#00007F">Sub</SPAN> BringProductAndItsNutritionValuesIntoMainFileAbbrev()<br><SPAN style="color:#00007F">Let</SPAN> MainFile = "MrExcelSortBeispielMainFile.xlsm"<br><SPAN style="color:#00007F">Let</SPAN> InputFile = "MrExcelSortBeispielFileToBeInputInMainFile.xlsx"<br><br><SPAN style="color:#00007F">For</SPAN> j = 1 <SPAN style="color:#00007F">To</SPAN> 40<br>    <SPAN style="color:#00007F">For</SPAN> x = 1 <SPAN style="color:#00007F">To</SPAN> 24<br>        <SPAN style="color:#00007F">For</SPAN> y = 1 <SPAN style="color:#00007F">To</SPAN> 10<br>            <SPAN style="color:#00007F">If</SPAN> Windows(InputFile).ActiveSheet.Cells(j, 1).Value = Windows(MainFile).ActiveSheet.Cells(y, x).Value And _<br>                Windows(InputFile).ActiveSheet.Cells(j, 1).Value <> "" <SPAN style="color:#00007F">Then</SPAN><br>                Windows(MainFile).ActiveSheet.Cells(ActiveCell.Row, x).Value = Windows(InputFile).ActiveSheet.Cells(j, 2).Value<br>            <SPAN style="color:#00007F">Else</SPAN><br>            <SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">If</SPAN><br>        <SPAN style="color:#00007F">Next</SPAN> y<br>    <SPAN style="color:#00007F">Next</SPAN> x<br><SPAN style="color:#00007F">Next</SPAN> j<br><SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">Sub</SPAN></FONT>

……….
. Here is the full code with comments):-

<font face=Calibri><SPAN style="color:#00007F">Option</SPAN> <SPAN style="color:#00007F">Explicit</SPAN> <SPAN style="color:#007F00">' Good practice: Cut down on memory usage and Make mistakes easier to notice</SPAN><br><SPAN style="color:#00007F">Sub</SPAN> BringProductAndItsNutritionValuesIntoMainFile()<br><SPAN style="color:#007F00">' The Main File and File to be put into the Main File must be open</SPAN><br><SPAN style="color:#007F00">' You must Select any cell in the Row in the Main File in which you want this new product to be listed</SPAN><br><SPAN style="color:#00007F">On</SPAN> <SPAN style="color:#00007F">Error</SPAN> <SPAN style="color:#00007F">GoTo</SPAN> TheEnd <SPAN style="color:#007F00">' If anything goes wrong, then instead of crashing go to end and end VBA</SPAN><br><SPAN style="color:#00007F">Dim</SPAN> j <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Integer</SPAN>, x <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Integer</SPAN>, y <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Integer</SPAN>  <SPAN style="color:#007F00">' Integer variables for count in Loops</SPAN><br><SPAN style="color:#00007F">Dim</SPAN> MainFile <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">String</SPAN>, InputFile <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">String</SPAN> <SPAN style="color:#007F00">' Spreadsheet names of Main File and File to be inputted into main file</SPAN><br><SPAN style="color:#00007F">Let</SPAN> MainFile = "MrExcelSortBeispielMainFile.xlsm"<br><SPAN style="color:#00007F">Let</SPAN> InputFile = "MrExcelSortBeispielFileToBeInputInMainFile.xlsx"<br><SPAN style="color:#007F00">'#Loops:  For every Row (j) in Input File......</SPAN><br><SPAN style="color:#00007F">For</SPAN> j = 1 <SPAN style="color:#00007F">To</SPAN> 40 <SPAN style="color:#00007F">Step</SPAN> 1 <SPAN style="color:#007F00">' 40 is an arbitrary number. It may mean looking at empty cells, but who cares, and anyway problems often crop up anyway when trying to determine the end of file, so keep it simple</SPAN><br>    <SPAN style="color:#007F00">'# .... Go through every column (x) in main file.....</SPAN><br>    <SPAN style="color:#00007F">For</SPAN> x = 1 <SPAN style="color:#00007F">To</SPAN> 24 <SPAN style="color:#00007F">Step</SPAN> 1<br>        <SPAN style="color:#007F00">'# .....look for a matching nutrition name in one of the 10 possible spelling variations</SPAN><br>        <SPAN style="color:#00007F">For</SPAN> y = 1 <SPAN style="color:#00007F">To</SPAN> 10 <SPAN style="color:#00007F">Step</SPAN> 1<br>            <SPAN style="color:#007F00">'......if a match is found....</SPAN><br>            <SPAN style="color:#007F00">'(......but ignooring matches for empty cels.....)</SPAN><br>            <SPAN style="color:#00007F">If</SPAN> Windows(InputFile).ActiveSheet.Cells(j, 1).Value = Windows(MainFile).ActiveSheet.Cells(y, x).Value And _<br>                Windows(InputFile).ActiveSheet.Cells(j, 1).Value <> "" <SPAN style="color:#00007F">Then</SPAN><br>                <SPAN style="color:#007F00">' .....then include that value in the main file in the row you have selected in the main file in the appropriate, that is to say matching column</SPAN><br>                Windows(MainFile).ActiveSheet.Cells(ActiveCell.Row, x).Value = Windows(InputFile).ActiveSheet.Cells(j, 2).Value<br>            <SPAN style="color:#00007F">Else</SPAN> <SPAN style="color:#007F00">'... otherwise does nothing</SPAN><br>            <SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">If</SPAN><br>        <SPAN style="color:#00007F">Next</SPAN> y<br>    <SPAN style="color:#00007F">Next</SPAN> x<br><SPAN style="color:#00007F">Next</SPAN> j<br>TheEnd:<br>End <SPAN style="color:#00007F">Sub</SPAN> <SPAN style="color:#007F00">'BringProductAndItsNutritionValuesIntomainFile()</SPAN></FONT>
………………

. A typical table for incorporating into the Main file could look like):-


Book1
AB
1nameClifEnergyBarPeanutButter
2
3Energy373
4Proteins16
5Carbohydrates54
6Sugers31
7Fat8.8
8Fibre5.9
9Sodium0.35
10
11Vitamin A0.000441
12Vitamin D0.0015
13Vitamin E0.0065
14Vitamin C0.00023
15Thiamin0.00023
16Riboflavin0.000375
17Niacin0.0044
18Vitamin B60.0006
19Vitamin B120.0000015
20Calcium0.221
21Magnesium0.081
22
23
24
Tabelle1

………………

. The first part of the main file looks like this before running the code).-


Book1
ABCDEFGHIJKLMNOPQ
1nameKcalFettEiweiKohZucker
2Name78910111213141516
3
4DescriptionEnergie:fatProteinKohlenhydrateSugar
5BeschreibungkcalFateiweissKohlenhydratSugars
6KilocalorienfetteEiwei:kohlenhydratesugars
7KilocaloriesFetteCarbohydratesKZ
8EnergyProteinsProteinsCarbohydratesSugers
9
10
11
12
13
14
15
16
Tabelle1



……..and like this after running the code):-


Book1
ABCDEFGHIJKLMNOPQ
1nameKcalFettEiweiKohZucker
2Name78910111213141516
3
4DescriptionEnergie:fatProteinKohlenhydrateSugar
5BeschreibungkcalFateiweissKohlenhydratSugars
6KilocalorienfetteEiwei:kohlenhydratesugars
7KilocaloriesFetteCarbohydratesKZ
8EnergyProteinsProteinsCarbohydratesSugers
9
10
11
12
13ClifEnergyBarPeanutButter3738.8165431
14
Tabelle1



. The program does nothing more than sort the data into the correct columns in the Main File. What is perhaps unusual, unique (or stupid??) is that the headings are in 10 rows instead of the usual one first row. That gives flexibility and it works fine for me. I would like to keep it simple and certainly avoid learning ACCESS (which would not be able to cope with the size of my final main file anyway!!). As I have virtually no experience I thought I would drop the idea in the forum on the off-chance that a Profi could point me in the direction of a more usual way that something of this nature is done?? I did try a similar process using Arrays in VBA, but had to give up on that because some of my files are German and I could not get over the continue problems caused by the different German and English conventions for comers and points in Decimal Points and Thousand Separators (http://www.mrexcel.com/forum/questi...cations-komma-punkt-tausend-zahl-problem.html ).
. Any suggestions for improvements or comments generally on my Sort method are welcome.
Thanks,
Alan
Bavaria

P.s. 1) here are the two files: (They must both be open in a Window for the code to work)

in Excel 2007 ( .xlsm and .xlsx)
Main File (With Macros in Module “InputToMainFile”) - FileSnack | Easy file sharing
File for Input - FileSnack | Easy file sharing
;
And in Excel 2003 (.xls and .xls) FileSnack | Easy file sharing
Main File (With Macros in Module “InputToMainFile”) - FileSnack | Easy file sharing
File for Input -

Note: The main File is just an Example I made for the Thread. The actual main File to stand looks like This!!!! ):- FileSnack | Easy file sharing

P.s. 2) I use mostly excel 2007 and 2010 in XP and Vista… ( But I’m thinking of going backward and using 2003)
 

Excel Facts

Excel Joke
Why can't spreadsheets drive cars? They crash too often!
Sort by date Sort by votes
CORRECTION!


DocAElstein said:
P.s. 1) here are the two files: (They must both be open in a Window for the code to work)

in Excel 2007 ( .xlsm and .xlsx)
Main File (With Macros in Module “InputToMainFile”) - FileSnack | Easy file sharing
File for Input - FileSnack | Easy file sharing
;
And in Excel 2003 (.xls and .xls) FileSnack | Easy file sharing
Main File (With Macros in Module “InputToMainFile”) - FileSnack | Easy file sharing
File for Input -

Note: The main File is just an Example I made for the Thread. The actual main File to stand looks like This!!!! ):- FileSnack | Easy file sharing

P.s. 2) I use mostly excel 2007 and 2010 in XP and Vista… ( But I’m thinking of going backward and using 2003)
Click to expand...


Oops!. I mixed up my example file Links, Here they are again:

in Excel 2007 ( .xlsm and .xlsx)
Main File (With Macros in Module “InputToMainFile”) - FileSnack | Easy file sharing
File for Input - FileSnack | Easy file sharing
;
And in Excel 2003 (.xls and .xls)
Main File (With Macros in Module “InputToMainFile”) - FileSnack | Easy file sharing
File for Input - FileSnack | Easy file sharing
 
Upvote 0
Hi,
. Just trying my luck again with this Thread, on the off-chance anyone has any ideas, for improvement, or general comments. It works for me, but I am keen to get things done a bit more professionally. (I did a correction that stopped it being a "No Response Button" candidate so might have missed out that way)
Thanks,
Alan
 
Upvote 0
Hi

(Bump). Or rather I am mainly just being responsible for an old thread of mine which although had no replies seems to have been viewed quite a bit. So I mainly I just wanted to update the files I gave for some minor typo’s.
. Having said that any suggestions at all for improvements in the Simple Sort Macro, or general comments are welcome, although since posting this thread in July I have already improved my knowledge with very simple sorting thanks to participating in and answering such threads, and particularly from seeing the responses to more experienced members


So, :- Files again with a few minor typo corrections

XL2007 main File (With Macro in Module InputToMainFileSimpleSort)
FileSnack | Easy file sharing
XL2007 File for input
FileSnack | Easy file sharing

XL2003 main File (With Macro in Module InputToMainFileSimpleSort)
FileSnack | Easy file sharing
XL2003 File for input
FileSnack | Easy file sharing

Hope it may help people stumbling across this Thread in the Future. If the simplest sort of sorting is of interest to you may find my replies to other simple sorting useful. But there are many more competent replies from other members, for example hiker95. As always a “site:MrExcel.com Google“ thing is always worth a shot. See my signature below.

Alan_Elston.
 
Upvote 0
…. I think this is a useful “follow-up” to this Thread (even if I do take the liberty of amusing myself and treating it somewhat light heartedly.….. )

Hi Alan,
. Firstly well done on your learning of VBA since joining MrExcel Forum.
. Coming back now to the original questions for improvements to the simple sort Program given in Post #1:
. 1 ) The real answer or “Profi” way to do it wound be:
. Firstly Capture the property of the ranges of interest to you ( in this case Value2 ) into an Array in a nice one liner. See here for example:
Range Dimensioning, Range and Value Referencing and Referring to Arrays
. Having done that you can go on to do all your complicated sorting, even much more complicated than in this example in code lines manipulating the inputted Arrays. The point here is that the speed advantages of working “internally” as it were over any method that continually references the Spreadsheet are so great that you do not have to worry too much about how complicated the lines manipulating the data are. Tests by many people often show that using complicated routines in code lines to achieve the things obtainable through a simple aplication of OOP dot stuff " .DoAllThat " can in fact be a lot faster. ( Many profis still resort back therefore to this method which looks then more like old fashioned programming code.. )
.. Along these lines, your required output should be written within these routines to an output Array. Once “full” this Array can usually be “re-written out” as it were in a “one Liner, again minimizing the interaction with the spreadsheet.
. Other things to bear in mind are, for example, getting a good understanding of the “Key - Item Pair Microsoft Scripting Runtime Dictionary (MSRD) Thing” which in sorting codes often comes in very useful, particularly where the requirement of the MSRD having unique keys (“identification things”) for it’s constituent Dictionary Items. Remember also to be very careful with explicitly defining things, especially References to specific spreadsheet Ranges. For detailed explanations of the above see the many Threads of this sorting nature that you have answered where you destroyed the codes with green explaining comments! color=grey](if you can find them??)…. Then a few at the end / in next thread.. .[/color]…..

. 2 ) Having said all that, if you are not doing your sorting too often speed may not be too important and a simple “Spreadsheet” type approach as given in your simple example at the beginning of this thread can certainly be a lot easier to “follow “ through and understand. At least if you can somehow get those annoying comments “off the screen” as it were, as they are to (not to) see in the VB Development Environment Window ( You can then scroll right if you need to see them. ). The Watch window can help to see what is going on with an Array tape sorting code. But the Watch Window can be difficult to navigate when Arrays are large.
. 2 a) Occasionally there are useful methods and Properties of Range Objects which simply are not possible in Arrays. Let me see now if I can give some real VBA feedback to this Thread to demonstrate ….. Consider you have that untypical “extra loop for your untypical “multiple headings”
.. looking again at those sheets , the “Data for input”
Excel 2007
[Table="width:, class:grid"][tr][td]-[/td][td]
A​
[/td][td]
B​
[/td][/tr]
[tr][td]
1​
[/td][td]name[/td][td]ClifEnergyBarPeanutButter[/td][/tr]

[tr][td]
2​
[/td][td][/td][td][/td][/tr]

[tr][td]
3​
[/td][td]Energy[/td][td]
373​
[/td][/tr]

[tr][td]
4​
[/td][td]Proteins[/td][td]
16​
[/td][/tr]

[tr][td]
5​
[/td][td]Carbohydrates[/td][td]
54​
[/td][/tr]

[tr][td]
6​
[/td][td]Sugers[/td][td]
31​
[/td][/tr]

[tr][td]
7​
[/td][td]Fat[/td][td]
8.8​
[/td][/tr]

[tr][td]
8​
[/td][td]Fibre[/td][td]
5.9​
[/td][/tr]

[tr][td]
9​
[/td][td]Sodium[/td][td]
0.35​
[/td][/tr]

[tr][td]
10​
[/td][td][/td][td][/td][/tr]

[tr][td]
11​
[/td][td]Vitamin A[/td][td]
0.000441​
[/td][/tr]

[tr][td]
12​
[/td][td]Vitamin D[/td][td]
0.0015​
[/td][/tr]

[tr][td]
13​
[/td][td]Vitamin E[/td][td]
0.0065​
[/td][/tr]

[tr][td]
14​
[/td][td]Vitamin C[/td][td]
0.00023​
[/td][/tr]

[tr][td]
15​
[/td][td]Thiamin[/td][td]
0.00023​
[/td][/tr]

[tr][td]
16​
[/td][td]Riboflavin[/td][td]
0.000375​
[/td][/tr]

[tr][td]
17​
[/td][td]Niacin[/td][td]
0.0044​
[/td][/tr]

[tr][td]
18​
[/td][td]Vitamin B6[/td][td]
0.0006​
[/td][/tr]

[tr][td]
19​
[/td][td]Vitamin B12[/td][td]
0.0000015​
[/td][/tr]

[tr][td]
20​
[/td][td]Calcium[/td][td]
0.221​
[/td][/tr]

[tr][td]
21​
[/td][td]Magnesium[/td][td]
0.081​
[/td][/tr]
[/table][Table="width:, class:grid"][tr][td]Tabelle1[/td][/tr][/table]

And Output sheet “Before” :

Excel 2007
[Table="width:, class:grid"][tr][td]-[/td][td]
A​
[/td][td]
B​
[/td][td]
C​
[/td][td]
D​
[/td][td]
E​
[/td][td]
F​
[/td][td]
G​
[/td][td]
H​
[/td][td]
I​
[/td][td]
J​
[/td][td]
K​
[/td][td]
L​
[/td][td]
M​
[/td][td]
N​
[/td][td]
O​
[/td][td]
P​
[/td][td]
Q​
[/td][td]
R​
[/td][td]
S​
[/td][td]
T​
[/td][td]
U​
[/td][td]
V​
[/td][td]
W​
[/td][td]
X​
[/td][/tr]
[tr][td]
1​
[/td][td]name[/td][td]t[/td][td]
​
[/td][td]
​
[/td][td]
​
[/td][td]
6​
[/td][td]
7​
[/td][td]Kcal[/td][td][/td][td]Fett[/td][td][/td][td]Eiweiß[/td][td][/td][td]Koh[/td][td][/td][td]Zucker[/td][td][/td][td]Ballaststoffe gesamt[/td][td][/td][td]Wasser[/td][td][/td][td]Kalium[/td][td][/td][td]Natrium+[/td][/tr]

[tr][td]
2​
[/td][td]Name[/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td]
7​
[/td][td]
8​
[/td][td]
9​
[/td][td]
10​
[/td][td]
11​
[/td][td]
12​
[/td][td]
13​
[/td][td]
14​
[/td][td]
15​
[/td][td]
16​
[/td][td]
17​
[/td][td]
18​
[/td][td]
19​
[/td][td]
20​
[/td][td]
21​
[/td][td]
22​
[/td][td]
23​
[/td][/tr]

[tr][td]
3​
[/td][td][/td][td]z[/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td]rr[/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][/tr]

[tr][td]
4​
[/td][td]Description[/td][td]Beschreibung[/td][td][/td][td][/td][td][/td][td][/td][td][/td][td]Energie:[/td][td][/td][td]fat[/td][td][/td][td]Protein[/td][td][/td][td]Kohlenhydrate[/td][td][/td][td]Sugar[/td][td][/td][td]Total dietary fibre[/td][td][/td][td]Water[/td][td][/td][td]Potassium[/td][td][/td][td]Sodium[/td][/tr]

[tr][td]
5​
[/td][td]Beschreibung[/td][td]t[/td][td][/td][td][/td][td][/td][td][/td][td][/td][td]kcal[/td][td][/td][td]Fat[/td][td][/td][td]eiweiss[/td][td][/td][td]Kohlenhydrat[/td][td][/td][td]Sugars[/td][td][/td][td]Fibre[/td][td][/td][td]water[/td][td][/td][td]kalium[/td][td][/td][td]Natrium:[/td][/tr]

[tr][td]
6​
[/td][td][/td][td]c[/td][td][/td][td][/td][td][/td][td][/td][td][/td][td]Kilocalorien[/td][td][/td][td]fette[/td][td][/td][td]Eiweiß:[/td][td][/td][td]kohlenhydrate[/td][td][/td][td]sugars[/td][td][/td][td]Ballastoffe[/td][td][/td][td]wasser[/td][td][/td][td]K[/td][td][/td][td]N+[/td][/tr]

[tr][td]
7​
[/td][td]Product[/td][td]r[/td][td][/td][td][/td][td][/td][td][/td][td][/td][td]Kilocalories[/td][td][/td][td]Fette[/td][td][/td][td][/td][td][/td][td]Carbohydrates[/td][td][/td][td]KZ[/td][td][/td][td][/td][td][/td][td]Wasser:[/td][td][/td][td][/td][td][/td][td][/td][/tr]

[tr][td]
8​
[/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td]Energy[/td][td][/td][td]F[/td][td][/td][td]Proteins[/td][td][/td][td]Carbohydrates[/td][td][/td][td]Sugers[/td][td][/td][td]Fibre[/td][td][/td][td][/td][td][/td][td][/td][td][/td][td]Sodium[/td][/tr]

[tr][td]
9​
[/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][/tr]

[tr][td]
10​
[/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td]ghjg[/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][/tr]

[tr][td]
11​
[/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][/tr]

[tr][td]
12​
[/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][/tr]

[tr][td]
13​
[/td][td]Select Here and Run Code[/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][/tr]

[tr][td]
14​
[/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][/tr]
[/table][Table="width:, class:grid"][tr][td]Tabelle1[/td][/tr][/table].

……

And “After”

Excel 2007
[Table="width:, class:grid"][tr][td]-[/td][td]
A​
[/td][td]
B​
[/td][td]
C​
[/td][td]
D​
[/td][td]
E​
[/td][td]
F​
[/td][td]
G​
[/td][td]
H​
[/td][td]
I​
[/td][td]
J​
[/td][td]
K​
[/td][td]
L​
[/td][td]
M​
[/td][td]
N​
[/td][td]
O​
[/td][td]
P​
[/td][td]
Q​
[/td][td]
R​
[/td][td]
S​
[/td][td]
T​
[/td][td]
U​
[/td][td]
V​
[/td][td]
W​
[/td][td]
X​
[/td][/tr]
[tr][td]
1​
[/td][td]name[/td][td]t[/td][td]
​
[/td][td]
​
[/td][td]
​
[/td][td]
6​
[/td][td]
7​
[/td][td]Kcal[/td][td][/td][td]Fett[/td][td][/td][td]Eiweiß[/td][td][/td][td]Koh[/td][td][/td][td]Zucker[/td][td][/td][td]Ballaststoffe gesamt[/td][td][/td][td]Wasser[/td][td][/td][td]Kalium[/td][td][/td][td]Natrium+[/td][/tr]

[tr][td]
2​
[/td][td]Name[/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td]
7​
[/td][td]
8​
[/td][td]
9​
[/td][td]
10​
[/td][td]
11​
[/td][td]
12​
[/td][td]
13​
[/td][td]
14​
[/td][td]
15​
[/td][td]
16​
[/td][td]
17​
[/td][td]
18​
[/td][td]
19​
[/td][td]
20​
[/td][td]
21​
[/td][td]
22​
[/td][td]
23​
[/td][/tr]

[tr][td]
3​
[/td][td][/td][td]z[/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td]rr[/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][/tr]

[tr][td]
4​
[/td][td]Description[/td][td]Beschreibung[/td][td][/td][td][/td][td][/td][td][/td][td][/td][td]Energie:[/td][td][/td][td]fat[/td][td][/td][td]Protein[/td][td][/td][td]Kohlenhydrate[/td][td][/td][td]Sugar[/td][td][/td][td]Total dietary fibre[/td][td][/td][td]Water[/td][td][/td][td]Potassium[/td][td][/td][td]Sodium[/td][/tr]

[tr][td]
5​
[/td][td]Beschreibung[/td][td]t[/td][td][/td][td][/td][td][/td][td][/td][td][/td][td]kcal[/td][td][/td][td]Fat[/td][td][/td][td]eiweiss[/td][td][/td][td]Kohlenhydrat[/td][td][/td][td]Sugars[/td][td][/td][td]Fibre[/td][td][/td][td]water[/td][td][/td][td]kalium[/td][td][/td][td]Natrium:[/td][/tr]

[tr][td]
6​
[/td][td][/td][td]c[/td][td][/td][td][/td][td][/td][td][/td][td][/td][td]Kilocalorien[/td][td][/td][td]fette[/td][td][/td][td]Eiweiß:[/td][td][/td][td]kohlenhydrate[/td][td][/td][td]sugars[/td][td][/td][td]Ballastoffe[/td][td][/td][td]wasser[/td][td][/td][td]K[/td][td][/td][td]N+[/td][/tr]

[tr][td]
7​
[/td][td]Product[/td][td]r[/td][td][/td][td][/td][td][/td][td][/td][td][/td][td]Kilocalories[/td][td][/td][td]Fette[/td][td][/td][td][/td][td][/td][td]Carbohydrates[/td][td][/td][td]KZ[/td][td][/td][td][/td][td][/td][td]Wasser:[/td][td][/td][td][/td][td][/td][td][/td][/tr]

[tr][td]
8​
[/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td]Energy[/td][td][/td][td]F[/td][td][/td][td]Proteins[/td][td][/td][td]Carbohydrates[/td][td][/td][td]Sugers[/td][td][/td][td]Fibre[/td][td][/td][td][/td][td][/td][td][/td][td][/td][td]Sodium[/td][/tr]

[tr][td]
9​
[/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][/tr]

[tr][td]
10​
[/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td]ghjg[/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][/tr]

[tr][td]
11​
[/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][/tr]

[tr][td]
12​
[/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][/tr]

[tr][td]
13​
[/td][td]ClifEnergyBarPeanutButter[/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td]
373​
[/td][td][/td][td]
8.8​
[/td][td][/td][td]
16​
[/td][td][/td][td]
54​
[/td][td][/td][td]
31​
[/td][td][/td][td]
5.9​
[/td][td][/td][td][/td][td][/td][td][/td][td][/td][td]
0.35​
[/td][/tr]

[tr][td]
14​
[/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][/tr]
[/table][Table="width:, class:grid"][tr][td]Tabelle1[/td][/tr][/table]


. An “Improvement” - You can do away with both your extra “Heading Loop” and also the check for an empty Look up cell.
. But knowing about exactly how these things work tend to rely on a lot of experience and are rarely documented well. Based on a sort of “Match On Error Pair” Trick. … for example touched on here.. (My Code explanations (also everywhere in my ‘Comments[color]….. ) and TMS Error explanations)[color]…..
.Match with On Error: On Error Resume Next works. On Error GoTo only works once. Err.Clear
…. And in the new codes below…and big ones in next Post #6)
.
. So finally a code alternative to that in Post #1.

Code with Comments:

Code: 
[color=blue]Sub[/color] BringProductAndItsNutritionValuesIntoMainFile2()
[color=blue]Let[/color] MainFile = "MrExcelSortBeispielMainFile2007.xlsm"
[color=blue]Let[/color] InputFile = "MrExcelSortBeispielFileToBeInputInMainFile2007.xlsx"
 
[color=blue]For[/color] j = 1 [color=blue]To[/color] 40
    [color=blue]For[/color] x = 1 [color=blue]To[/color] 24
        [color=lightgreen]'For y = 1 To 10[/color]
                [color=lightgreen]'If Windows(InputFile).ActiveSheet.Cells(j, 1).Value <> "" Then[/color]
                    [color=blue]On[/color] [color=blue]Error[/color] [color=blue]Resume[/color] [color=blue]Next[/color] [color=lightgreen]'This works such that if we error at the next line we go directly to the next line under this errored line[/color]
                    [color=blue]If[/color] Application.WorksheetFunction.Match(Windows(InputFile).ActiveSheet.Cells(j, 1), Windows(MainFile).ActiveSheet.Columns(x), 0) = -3566 [color=blue]Then[/color] [color=lightgreen]' -3566 will never occur. But we either error here or have an indicie of  1,  2,, 3.... etc. Also you error if trying to match an empty cell.[/color]
                    [color=lightgreen]'Error Situation: We had no match so we actually go to next bit which is the Here or rasther End If as nothing is here[/color]
                    [color=blue]Else[/color] [color=lightgreen]'We come here if no error but the Match indicie was not -3566. So that is pour normal match condition[/color]
                    Windows(MainFile).ActiveSheet.Cells(ActiveCell.Row, x).Value = Windows(InputFile).ActiveSheet.Cells(j, 2).Value
                    [color=blue]End[/color] [color=blue]If[/color]
                [color=lightgreen]'Else[/color]
                'End If
        [color=lightgreen]'Next y[/color]
    Next x
Next j
[color=blue]End[/color] [color=lightgreen]'SubBringProductAndItsNutritionValuesIntoMainFile2[/color]
[color=lightgreen]'[/color]

And Code without comments:

<font face=Calibri><SPAN style="color:#00007F">Sub</SPAN> BringProductAndItsNutritionValuesIntoMainFileAbbrev2()<br><SPAN style="color:#00007F">Let</SPAN> MainFile = "MrExcelSortBeispielMainFile2007.xlsm"<br><SPAN style="color:#00007F">Let</SPAN> InputFile = "MrExcelSortBeispielFileToBeInputInMainFile2007.xlsx"<br><br><SPAN style="color:#00007F">For</SPAN> j = 1 <SPAN style="color:#00007F">To</SPAN> 40<br>    <SPAN style="color:#00007F">For</SPAN> x = 1 <SPAN style="color:#00007F">To</SPAN> 24<br>                  <SPAN style="color:#00007F">On</SPAN> <SPAN style="color:#00007F">Error</SPAN> <SPAN style="color:#00007F">Resume</SPAN> <SPAN style="color:#00007F">Next</SPAN><br>                    <SPAN style="color:#00007F">If</SPAN> Application.WorksheetFunction.Match(Windows(InputFile).ActiveSheet.Cells(j, 1), Windows(MainFile).ActiveSheet.Columns(x), 0) = -3566 <SPAN style="color:#00007F">Then</SPAN><br>                    <SPAN style="color:#00007F">Else</SPAN><br>                    Windows(MainFile).ActiveSheet.Cells(ActiveCell.Row, x).Value = Windows(InputFile).ActiveSheet.Cells(j, 2).Value<br>                    <SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">If</SPAN><br>    <SPAN style="color:#00007F">Next</SPAN> x<br><SPAN style="color:#00007F">Next</SPAN> j<br><SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">Sub</SPAN></FONT>

……………………………………………………………………………

. That is the sort of “improvement” you were hoping to get from this Thread. Instead you have with kind help from this and recently other Forums been able to learn enough to come up with things like that yourself. Which is better in the long run ( for all of me’s / us ? )

. Alan
 
Upvote 0
. Nice Follow – Up! Thanks Alan ( u m nutter! )

P.s. FileSnack closed down, so the sample Files wes gaves are not available. So here they are again via Box

XL2007.xlsm main File (With Macro in Module InputToMainFileSimpleSort)
https://app.box.com/s/hkixm5a5f34v9yvogd4h4bmlpd4jjtuq
XL2007.xlsx File for input
https://app.box.com/s/nttxy6e7ndsi4blmbx2nqy859i6yqq1r


… and while you are here
P.s. 2.
.. a recent real Life example relevant to you of The “VBA Array” versus “Spreadsheet” approach. Based on what you have learnt from MrExcel you have initial “real life” Files .

Main Full Product List File (No Macros this time ) ( XL 2007.xlsx )
https://app.box.com/s/t0utcujdggd7sm8xr1x4


File for Input (Macros in this File this time ) ( XL 2007 .xlsm )
https://app.box.com/s/x362u3cg0i7t1zqncyto5d92p85haxf5

…… and here some speed results:


[Table="width:, class:grid"]
[tr][td]Code Type[/td][td]
Av. Time seconds​
[/td][td]
​
[/td][/tr]

[tr][td][/td][td]Comp 1 XL 2007[/td][td]Comp 2 XL 2010[/td][/tr]

[tr][td]"VBA Arrays" Approach[/td][td]
0.035​
[/td][td]
0.05​
[/td][/tr]

[tr][td]"Spreadsheet" Approach[/td][td]
4.59​
[/td][td]
9.54​
[/td][/tr]

[tr][td]"Spreadsheet" Approach MatchOnErrPair[/td][td]
9.66​
[/td][td]
3.9​
[/td][/tr]

[tr][td]"Spreadsheet" Approach MatchOnErrPairShortenedHeaderColumn[/td][td]
8.2​
[/td][td]
0.47​
[/td][/tr]
[/table]

. Just goes to show the advantage of working with Arrays (even if multiple loops are involved)..and the last mod “Match On Error Pair” was not always the “Bringer” always** either… **although looking at a particular computer and or a particular XL version is always worth a try..?!?.!!


Alan.

P.s. Codes for those tests, also given in the Files ( This time Codes in File for Input ( which can also bring information direct from a Internet site) )



Code: 
[color=blue]Option[/color] [color=blue]Explicit[/color]
[color=lightgreen]' next 2 lines needed for 'Charley Williams Micro Timer Code[/color]
[color=blue]Private[/color] [color=blue]Declare[/color] [color=blue]Function[/color] getFrequency [color=blue]Lib[/color] "kernel32" Alias "QueryPerformanceFrequency" (cyFrequency [color=blue]As[/color] [color=blue]Currency[/color]) [color=blue]As[/color] [color=blue]Long[/color]
[color=blue]Private[/color] [color=blue]Declare[/color] [color=blue]Function[/color] getTickCount [color=blue]Lib[/color] "kernel32" Alias "QueryPerformanceCounter" (cyTickCount [color=blue]As[/color] [color=blue]Currency[/color]) [color=blue]As[/color] [color=blue]Long[/color]
 
[color=lightgreen]'[/color]
'
'
'
'
[color=blue]Sub[/color] TransferDebiNetToDumpArrays()
    [color=lightgreen]'Initila Sheet Names / File Names[/color]
    [color=blue]Dim[/color] wksL2 [color=blue]As[/color] Worksheet: [color=blue]Set[/color] wksL2 = ThisWorkbook.Worksheets("Leith2") [color=lightgreen]'Main Sheet for Imported Nutrients[/color]
    [color=blue]Dim[/color] FileName [color=blue]As[/color] String: [color=blue]Let[/color] FileName = ThisWorkbook.Name [color=lightgreen]'Need to do a bit of mucking about to get the window name[/color]
    [color=blue]Dim[/color] WindowFileName [color=blue]As[/color] [color=blue]String[/color] [color=lightgreen]'File name as typically seen displayed without last bit after dot[/color]
    [color=blue]Let[/color] WindowFileName = Left(FileName, (InStrRev(FileName, ".") - 1)) [color=lightgreen]'Take off the bit after the dot[/color]
    [color=blue]Dim[/color] objWin [color=blue]As[/color] Object: [color=blue]Set[/color] objWin = Windows("11 172x49ExtRowsGruppiertDumpAbDec2014ISSC") [color=lightgreen]'Mainly for Conveneince[/color]
   
    [color=lightgreen]'Bring both sheet data into various Arrays. Set ## to last column wanted in Master to Fill in[/color]
    objWin.Activate [color=lightgreen]'ActiveCell below will not work without this[/color]
    [color=blue]Dim[/color] ARow [color=blue]As[/color] [color=blue]Long[/color], Acolumn [color=blue]As[/color] [color=blue]Long[/color], lc [color=blue]As[/color] [color=blue]Long[/color] [color=lightgreen]'Current Active Cell[/color]
    [color=blue]Let[/color] ARow = ActiveCell.Row: [color=blue]Let[/color] Acolumn = ActiveCell.Column [color=lightgreen]'Get cell coordinates for selected range. (For a range, the top left cell coordinates are returned)[/color]
    ActiveSheet.Range("a" & ARow & ":CU" & ARow & "").Select [color=lightgreen]'##CU (Vitamine) Extended selection range to include everything wanted.[/color]
    wksL2.Activate [color=lightgreen]'Mainly to see what is going on, and the next line still works!?[/color]
    [color=lightgreen]'The Selected Food (and also the Heading (NutritionArray) by .offset.resizemethod[/color]
    [color=blue]Dim[/color] RngFood [color=blue]As[/color] Range: [color=blue]Set[/color] RngFood = objWin.Selection
    [color=blue]Dim[/color] ArrOrigEntries() [color=blue]As[/color] Variant: [color=blue]Let[/color] ArrOrigEntries() = RngFood.Value2 [color=lightgreen]'Value2 is the underlying value, quickes and most accurate to get to http://www.excelforum.com/excel-new-users-basics/1058406-range-dimensioning-range-and-value-referencing-and-referring-to-arrays.html[/color]
    [color=blue]Dim[/color] RngNut [color=blue]As[/color] Range: [color=blue]Set[/color] RngNut = RngFood.Offset(-ARow + 1, 0).Resize(20)
    [color=blue]Dim[/color] ArrFood() [color=blue]As[/color] [color=blue]Variant[/color], ArrNut() [color=blue]As[/color] [color=blue]Variant[/color] [color=lightgreen]'CVhoose variant both to allow for "" and also to allow one liner throgh Range Object to work.[/color]
    [color=blue]Let[/color] ArrFood() = RngFood.Value2: [color=blue]Let[/color] ArrNut() = RngNut.Value2 [color=lightgreen]'VBA Capture possibility to bring in values in one liner[/color]
    [color=blue]Let[/color] lc = [color=blue]UBound[/color](ArrFood, 2) [color=lightgreen]': Let lc = 99'=CU[/color]
    [color=lightgreen]'The Selected Food from Kcal[/color]
    objWin.Activate [color=lightgreen]'ActiveCell below will not work without this[/color]
    ActiveSheet.Range("H" & ARow & ":CU" & ARow & "").Select
    [color=blue]Dim[/color] RngFoodAbKcal [color=blue]As[/color] Range: [color=blue]Set[/color] RngFoodAbKcal = objWin.Selection
    [color=blue]Dim[/color] ArrOrigAbKcaEntries() [color=blue]As[/color] Variant: [color=blue]Let[/color] ArrOrigAbKcaEntries() = RngFoodAbKcal.Value2 [color=lightgreen]'Variant is not only necerssary for seeing Range Object, but also if it was for example a number than it will have 0s in place of empty cells[/color]
   
    [color=lightgreen]'The DebiNet imported range. May be advisable to set this Manually sometimes[/color]
    [color=blue]Dim[/color] lDbNr [color=blue]As[/color] Long: [color=blue]Let[/color] lDbNr = wksL2.Cells.Find(What:="*", After:=wksL2.Cells(1, 1), Lookat:=xlPart, LookIn:=xlFormulas, SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row [color=lightgreen]'Get last Row with entry anywhere for Sheet1. Method: You start at first cell then go backwards (which effectively starts at end of sheet), sercching for anything ( = * ) by rows, then get the row number. This allows for different excel versions with different available Row numbers) Just a different method that finds last row in sheet rather than row for last entry in particular cell. Better to use that here as we are not sure which columns are full[/color]
    [color=blue]Dim[/color] rngDebiNet [color=blue]As[/color] Range: [color=blue]Set[/color] rngDebiNet = wksL2.Range("A21:D" & lDbNr & "")
    [color=blue]Dim[/color] ArrDebiNet() [color=blue]As[/color] Variant: [color=blue]Let[/color] ArrDebiNet() = rngDebiNet.Value2 [color=lightgreen]'VBA Capture possibility to bring in values in one liner[/color]
 
    [color=lightgreen]'Now for Producing output Array, looping through looking for match conditions[/color]
    [color=blue]Dim[/color] Results() [color=blue]As[/color] Variant: [color=blue]ReDim[/color] Results(1 [color=blue]To[/color] 1, 1 [color=blue]To[/color] lc) [color=lightgreen]'Output results.. must use ReDim as [color=blue]Dim[/color] only takes actual numbers. variant must be used for text as well as Number entries, but also so that empty cells will remain as empty rather than beinng replaced by 0s[/color]
    [color=blue]Dim[/color] r [color=blue]As[/color] [color=blue]Long[/color], c [color=blue]As[/color] [color=blue]Long[/color] [color=lightgreen]'Row and column in Debinet imported data[/color]
            [color=blue]Dim[/color] DumpColumn [color=blue]As[/color] [color=blue]Long[/color] [color=lightgreen]'Column of Master Dump[/color]
                [color=blue]Dim[/color] Headr [color=blue]As[/color] Long [color=lightgreen]'Heading Row, (1 to 20)[/color]
        [color=blue]For[/color] r = 21 - 20 [color=blue]To[/color] lDbNr - 20 [color=lightgreen]'Each debinet imported row. -20 must bbe used as starts at 1 due to the capture method[/color]
           [color=blue]If[/color] ArrDebiNet(r, 1) <> "" [color=blue]Then[/color] [color=lightgreen]'Efficiently only goint further if there is a Nutrition from Food Product[/color]
            [color=blue]For[/color] DumpColumn = 8 [color=blue]To[/color] lc [color=blue]Step[/color] 2 [color=lightgreen]'Go along each Master DumpColumn[/color]
                [color=blue]For[/color] Headr = 1 [color=blue]To[/color] 20 [color=lightgreen]'Going throght the Headings...[/color]
                    [color=blue]If[/color] ArrDebiNet(r, 1) = ArrNut(Headr, DumpColumn) [color=blue]Then[/color] [color=lightgreen]'Have heading match condition[/color]
                    [color=lightgreen]'MsgBox ArrDebiNet(r, 1) & " " & ArrNut(Headr, DumpColumn) & " " & ArrDebiNet(r, 4)'Debug hilfe[/color]
                    [color=blue]Let[/color] Results(1, DumpColumn) = ArrDebiNet(r, 4) [color=lightgreen]'Important match condition so put in Forth column In appropriate colum indiciee for output[/color]
                    [color=blue]Else[/color] [color=lightgreen]'No heading match[/color]
                    [color=blue]End[/color] [color=blue]If[/color]
                [color=blue]Next[/color] Headr [color=lightgreen]'Try next heading for match[/color]
            [color=blue]Next[/color] DumpColumn [color=lightgreen]'back to next Master DumpColumn[/color]
           [color=blue]Else[/color] [color=lightgreen]'Not doing any sorting for no Nurition from Food Product[/color]
           [color=blue]End[/color] [color=blue]If[/color]
        [color=blue]Next[/color] r [color=lightgreen]'Go to next imported debinet Row[/color]
       
        [color=lightgreen]'Produce the output, making check and possibility to put original values in. 3 Alternatives[/color]
        Dim AvResults() [color=blue]As[/color] Variant: [color=blue]ReDim[/color] AvResults(1 [color=blue]To[/color] 1, 8 To lc) [color=lightgreen]'First alternative looping for average results. Avv Results must be variant or empty cells will be replaced by 0s![/color]
            [color=blue]For[/color] DumpColumn = 8 To lc [color=lightgreen]'Go from Kcal[/color]
                [color=blue]If[/color] ArrOrigEntries(1, DumpColumn) <> "" And Results(1, DumpColumn) <> "" [color=blue]Then[/color]
                AvResults(1, DumpColumn) = Application.WorksheetFunction.Round((ArrOrigEntries(1, DumpColumn) + Results(1, DumpColumn)) / 2, 7)
                [color=blue]Else[/color] [color=lightgreen]'Case empty cell[/color]
                AvResults(1, DumpColumn) = Results(1, DumpColumn) [color=lightgreen]'Stay again in Variants to allow transfering "" for "" in Results[/color]
                [color=blue]End[/color] [color=blue]If[/color]
            [color=blue]Next[/color] DumpColumn
        [color=blue]Let[/color] RngFoodAbKcal.Value2 = AvResults()
 
[color=lightgreen]'        'Let RngFood.Value2 = Results() 'second Alternative one Liner to bypass above loop if all is empty and nothing in A-G[/color]
[color=lightgreen]'[/color]
'        'Msg Box check if all is well, if not put original enties back in. COMMENTED OUT FOR SPEED TESTS
[color=lightgreen]'        Dim Response As Integer 'In VBA Butons "yes is 6, 7 is "no"[/color]
[color=lightgreen]'        Response = MsgBox(prompt:="Is all OK?", Buttons:=vbYesNo, Title:="File Check") ' Displays a message box with the yes and no options.[/color]
[color=lightgreen]'        If Response = vbYes Then 'Do nothing, that is to say just carry on after End of If[/color]
[color=lightgreen]'        Else[/color]
'        Let RngFood.Value2 = ArrOrigEntries() 'Full repair!!':Let RngFoodAbKcal.Value2 = ArrOrigAbKcaEntries()'Repair only from Kcal
[color=lightgreen]'        End If[/color]
   
objWin.ActiveCell.Offset(0, -7).Select [color=lightgreen]'Just to be on the safe side in case you riun again (For example to get weighting avarage up), select back the first call in selection row[/color]
   
[color=blue]End[/color] [color=blue]Sub[/color] [color=lightgreen]'TransferDebiNetToDumpArrays[/color]
 
 
[color=lightgreen]'..................................................[/color]
[color=lightgreen]'[/color]
'
'
'
[color=blue]Sub[/color] TransferDebiNetToDumpMostSpreadsheet()
    [color=lightgreen]'Initial Sheet Names / File Names[/color]
    [color=blue]Dim[/color] wksL2 [color=blue]As[/color] Worksheet: [color=blue]Set[/color] wksL2 = ThisWorkbook.Worksheets("Leith2") [color=lightgreen]'Main Sheet for Imported Nutrients[/color]
    [color=blue]Dim[/color] FileName [color=blue]As[/color] String: [color=blue]Let[/color] FileName = ThisWorkbook.Name [color=lightgreen]'Need to do a bit of mucking about to get the window name[/color]
    [color=blue]Dim[/color] WindowFileName [color=blue]As[/color] [color=blue]String[/color] [color=lightgreen]'File name as typically seen displayed without last bit after dot[/color]
    [color=blue]Let[/color] WindowFileName = Left(FileName, (InStrRev(FileName, ".") - 1)) [color=lightgreen]'Take off the bit after the dot[/color]
    [color=blue]Dim[/color] objWin [color=blue]As[/color] Object: [color=blue]Set[/color] objWin = Windows("11 172x49ExtRowsGruppiertDumpAbDec2014ISSC") [color=lightgreen]'Mainly for Conveneince[/color]
   
    [color=lightgreen]'Make some back up initial data. - The Selected Food complete original Range and also The Selected original Food from KcalSet ## to last column wanted in Master to Fill in. (CU Vitamine)  range to include everything wanted.[/color]
    objWin.Activate [color=lightgreen]'ActiveCell below will not work without this[/color]
    [color=blue]Dim[/color] ARow [color=blue]As[/color] [color=blue]Long[/color], Acolumn [color=blue]As[/color] [color=blue]Long[/color], lc [color=blue]As[/color] [color=blue]Long[/color] [color=lightgreen]'Current Active Cell[/color]
    [color=blue]Let[/color] ARow = ActiveCell.Row: [color=blue]Let[/color] Acolumn = ActiveCell.Column [color=lightgreen]'Get cell coordinates for selected range. (For a range, the top left cell coordinates are returned)[/color]
    ActiveSheet.Range("A" & ARow & ":CU" & ARow & "").Select [color=lightgreen]'##CU (Vitamine) Extended selection range to include everything wanted.[/color]
    wksL2.Activate [color=lightgreen]'Mainly to see what is going on, and the next line still works!?[/color]
    [color=lightgreen]'        The Selected Food[/color]
    [color=blue]Dim[/color] RngFood [color=blue]As[/color] Range: [color=blue]Set[/color] RngFood = objWin.Selection
    [color=blue]Dim[/color] ArrOrigEntries() [color=blue]As[/color] Variant: [color=blue]Let[/color] ArrOrigEntries() = RngFood.Value2 [color=lightgreen]'Value2 is the underlying value, quickes and most accurate to get to http://www.excelforum.com/excel-new-users-basics/1058406-range-dimensioning-range-and-value-referencing-and-referring-to-arrays.html[/color]
    [color=blue]Dim[/color] ArrFood() [color=blue]As[/color] [color=blue]Variant[/color], ArrNut() [color=blue]As[/color] [color=blue]Variant[/color] [color=lightgreen]'CVhoose variant both to allow for "" and also to allow one liner throgh Range Object to work.[/color]
    [color=blue]Let[/color] ArrFood() = RngFood.Value2 [color=lightgreen]'VBA Capture possibility to bring in values in one liner[/color]
    [color=blue]Let[/color] lc = [color=blue]UBound[/color](ArrFood, 2) [color=lightgreen]': Let lc = 99'=CU[/color]
    [color=lightgreen]'        The Selected Food from Kcal[/color]
    objWin.Activate [color=lightgreen]'ActiveCell below will not work without this[/color]
    ActiveSheet.Range("H" & ARow & ":CU" & ARow & "").Select
    [color=blue]Dim[/color] RngFoodAbKcal [color=blue]As[/color] Range: [color=blue]Set[/color] RngFoodAbKcal = objWin.Selection
    [color=blue]Dim[/color] ArrOrigAbKcaEntries() [color=blue]As[/color] Variant: [color=blue]Let[/color] ArrOrigAbKcaEntries() = RngFoodAbKcal.Value2 [color=lightgreen]'Variant is not only necerssary for seeing Range Object, but also if it was for example a number than it will have 0s in place of empty cells[/color]
   
    [color=lightgreen]'Now main Loopin through spreadsheet, looking for match conditions, then writing in when match found[/color]
     [color=lightgreen]'The DebiNet imported range. May be advisable to set this Manually sometimes[/color]
    [color=blue]Dim[/color] lDbNr [color=blue]As[/color] [color=blue]Long[/color] [color=lightgreen]'The DebiNet imported range. May be advisable to set this Manually sometimes[/color]
    [color=blue]Let[/color] lDbNr = wksL2.Cells.Find(What:="*", After:=wksL2.Cells(1, 1), Lookat:=xlPart, LookIn:=xlFormulas, SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row [color=lightgreen]'Get last Row with entry anywhere for Sheet1. Method: You start at first cell then go backwards (which effectively starts at end of sheet), sercching for anything ( = * ) by rows, then get the row number. This allows for different excel versions with different available Row numbers) Just a different method that finds last row in sheet rather than row for last entry in particular cell. Better to use that here as we are not sure which columns are full[/color]
    [color=blue]Dim[/color] wksDump [color=blue]As[/color] Worksheet: [color=blue]Set[/color] wksDump = Workbooks("11 172x49ExtRowsGruppiertDumpAbDec2014ISSC.xlsx").Worksheets("Sheet1") [color=lightgreen]'Extra step over Array mehtod as objWin has no cells property, only an ActiveCell Property[/color]
    [color=blue]Dim[/color] r [color=blue]As[/color] [color=blue]Long[/color], c [color=blue]As[/color] [color=blue]Long[/color] [color=lightgreen]'Row and column in Debinet imported data[/color]
            [color=blue]Dim[/color] DumpColumn [color=blue]As[/color] [color=blue]Long[/color] [color=lightgreen]'Column of Master Dump[/color]
                [color=blue]Dim[/color] Headr [color=blue]As[/color] Long [color=lightgreen]'Heading Row, (1 to 20)[/color]
        [color=blue]For[/color] r = 21 [color=blue]To[/color] lDbNr   [color=lightgreen]'Each debinet imported row. -20 must bbe used as starts at 1 due to the capture method[/color]
           [color=blue]If[/color] wksL2.Cells(r, 1).Value <> "" [color=blue]Then[/color] [color=lightgreen]'Efficiently only goint further if there is a Nutrition from Food Product[/color]
            [color=blue]For[/color] DumpColumn = 8 [color=blue]To[/color] lc [color=blue]Step[/color] 2 [color=lightgreen]'Go along each Master DumpColumn[/color]
                [color=blue]For[/color] Headr = 1 [color=blue]To[/color] 20 [color=lightgreen]'Going throght the Headings...[/color]
                    [color=blue]If[/color] wksL2.Cells(r, 1).Value = wksDump.Cells(Headr, DumpColumn).Value [color=blue]Then[/color] [color=lightgreen]'Have heading match condition[/color]
                        [color=blue]If[/color] wksDump.Cells(ARow, DumpColumn).Value = "" [color=blue]Then[/color]  [color=lightgreen]'Case empty cell, no entry yet[/color]
                        [color=blue]Let[/color] wksDump.Cells(ARow, DumpColumn).Value = wksL2.Cells(r, 4).Value [color=lightgreen]'Important match condition so put in Forth column In appropriate colum indiciee for output[/color]
                        [color=blue]Else[/color] [color=lightgreen]'Presumably an entry is already there, and we already know we have a debinet entry, so as a first approximation put the average in[/color]
                        [color=blue]Let[/color] wksDump.Cells(ARow, DumpColumn).Value = Application.WorksheetFunction.Round((wksDump.Cells(ARow, DumpColumn).Value + wksL2.Cells(r, 4).Value) / 2, 7)
                        [color=blue]End[/color] [color=blue]If[/color]
                    [color=blue]Else[/color] [color=lightgreen]'No heading match[/color]
                    [color=blue]End[/color] [color=blue]If[/color]
                [color=blue]Next[/color] Headr [color=lightgreen]'Try next heading for match[/color]
            [color=blue]Next[/color] DumpColumn [color=lightgreen]'back to next Master DumpColumn[/color]
           [color=blue]Else[/color] [color=lightgreen]'Not doing any sorting for no Nurition from Food Product[/color]
           [color=blue]End[/color] [color=blue]If[/color]
        [color=blue]Next[/color] r [color=lightgreen]'Go to next imported debinet Row[/color]
       
[color=lightgreen]'        'Msg Box check if all is well, if not put original enties back in. COMMENTED OUT FOR SPEED TESTS[/color]
[color=lightgreen]'        Dim Response As Integer 'In VBA Butons "yes is 6, 7 is "no"[/color]
[color=lightgreen]'        Response = MsgBox(prompt:="Is all OK?", Buttons:=vbYesNo, Title:="File Check") ' Displays a message box with the yes and no options.[/color]
[color=lightgreen]'        If Response = vbYes Then 'Do nothing, that is to say just carry on after End of If[/color]
[color=lightgreen]'        Else[/color]
'        Let RngFood.Value2 = ArrOrigEntries() 'Full repair!!':Let RngFoodAbKcal.Value2 = ArrOrigAbKcaEntries()'Repair only from Kcal
[color=lightgreen]'        End If[/color]
   
    wksDump.Cells(ARow, 1).Activate [color=lightgreen]'Just to be on the safe side in case run again without checking active cell[/color]
[color=blue]End[/color] [color=blue]Sub[/color] [color=lightgreen]'TransferDebiNetToDumpMostSpreadSheet[/color]
[color=lightgreen]'[/color]
'
'
 
 
[color=blue]Sub[/color] TransferDebiNetToDumpMostSpreadsheetMatchOnErrPair()
    [color=lightgreen]'Initial Sheet Names / File Names[/color]
    [color=blue]Dim[/color] wksL2 [color=blue]As[/color] Worksheet: [color=blue]Set[/color] wksL2 = ThisWorkbook.Worksheets("Leith2") [color=lightgreen]'Main Sheet for Imported Nutrients[/color]
    [color=blue]Dim[/color] FileName [color=blue]As[/color] String: [color=blue]Let[/color] FileName = ThisWorkbook.Name [color=lightgreen]'Need to do a bit of mucking about to get the window name[/color]
    [color=blue]Dim[/color] WindowFileName [color=blue]As[/color] [color=blue]String[/color] [color=lightgreen]'File name as typically seen displayed without last bit after dot[/color]
    [color=blue]Let[/color] WindowFileName = Left(FileName, (InStrRev(FileName, ".") - 1)) [color=lightgreen]'Take off the bit after the dot[/color]
    [color=blue]Dim[/color] objWin [color=blue]As[/color] Object: [color=blue]Set[/color] objWin = Windows("11 172x49ExtRowsGruppiertDumpAbDec2014ISSC") [color=lightgreen]'Mainly for Conveneince[/color]
   
    [color=lightgreen]'Make some back up initial data. - The Selected Food complete original Range and also The Selected original Food from KcalSet ## to last column wanted in Master to Fill in. (CU Vitamine)  range to include everything wanted.[/color]
    objWin.Activate [color=lightgreen]'ActiveCell below will not work without this[/color]
    [color=blue]Dim[/color] ARow [color=blue]As[/color] [color=blue]Long[/color], Acolumn [color=blue]As[/color] [color=blue]Long[/color], lc [color=blue]As[/color] [color=blue]Long[/color] [color=lightgreen]'Current Active Cell[/color]
    [color=blue]Let[/color] ARow = ActiveCell.Row: [color=blue]Let[/color] Acolumn = ActiveCell.Column [color=lightgreen]'Get cell coordinates for selected range. (For a range, the top left cell coordinates are returned)[/color]
    ActiveSheet.Range("A" & ARow & ":CU" & ARow & "").Select [color=lightgreen]'##CU (Vitamine) Extended selection range to include everything wanted.[/color]
    wksL2.Activate [color=lightgreen]'Mainly to see what is going on, and the next line still works!?[/color]
    [color=lightgreen]'        The Selected Food[/color]
    [color=blue]Dim[/color] RngFood [color=blue]As[/color] Range: [color=blue]Set[/color] RngFood = objWin.Selection
    [color=blue]Dim[/color] ArrOrigEntries() [color=blue]As[/color] Variant: [color=blue]Let[/color] ArrOrigEntries() = RngFood.Value2 [color=lightgreen]'Value2 is the underlying value, quickes and most accurate to get to http://www.excelforum.com/excel-new-users-basics/1058406-range-dimensioning-range-and-value-referencing-and-referring-to-arrays.html[/color]
    [color=blue]Dim[/color] ArrFood() [color=blue]As[/color] [color=blue]Variant[/color], ArrNut() [color=blue]As[/color] [color=blue]Variant[/color] [color=lightgreen]'CVhoose variant both to allow for "" and also to allow one liner throgh Range Object to work.[/color]
    [color=blue]Let[/color] ArrFood() = RngFood.Value2 [color=lightgreen]'VBA Capture possibility to bring in values in one liner[/color]
    [color=blue]Let[/color] lc = [color=blue]UBound[/color](ArrFood, 2) [color=lightgreen]': Let lc = 99'=CU[/color]
    [color=lightgreen]'        The Selected Food from Kcal[/color]
    objWin.Activate [color=lightgreen]'ActiveCell below will not work without this[/color]
    ActiveSheet.Range("H" & ARow & ":CU" & ARow & "").Select
    [color=blue]Dim[/color] RngFoodAbKcal [color=blue]As[/color] Range: [color=blue]Set[/color] RngFoodAbKcal = objWin.Selection
    [color=blue]Dim[/color] ArrOrigAbKcaEntries() [color=blue]As[/color] Variant: [color=blue]Let[/color] ArrOrigAbKcaEntries() = RngFoodAbKcal.Value2 [color=lightgreen]'Variant is not only necerssary for seeing Range Object, but also if it was for example a number than it will have 0s in place of empty cells[/color]
   
    [color=lightgreen]'Now main Loopin through spreadsheet, looking for match conditions, then writing in when match found[/color]
     [color=lightgreen]'The DebiNet imported range. May be advisable to set this Manually sometimes[/color]
    [color=blue]Dim[/color] lDbNr [color=blue]As[/color] [color=blue]Long[/color] [color=lightgreen]'The DebiNet imported range. May be advisable to set this Manually sometimes[/color]
    [color=blue]Let[/color] lDbNr = wksL2.Cells.Find(What:="*", After:=wksL2.Cells(1, 1), Lookat:=xlPart, LookIn:=xlFormulas, SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row [color=lightgreen]'Get last Row with entry anywhere for Sheet1. Method: You start at first cell then go backwards (which effectively starts at end of sheet), sercching for anything ( = * ) by rows, then get the row number. This allows for different excel versions with different available Row numbers) Just a different method that finds last row in sheet rather than row for last entry in particular cell. Better to use that here as we are not sure which columns are full[/color]
    [color=blue]Dim[/color] wksDump [color=blue]As[/color] Worksheet: [color=blue]Set[/color] wksDump = Workbooks("11 172x49ExtRowsGruppiertDumpAbDec2014ISSC.xlsx").Worksheets("Sheet1") [color=lightgreen]'Extra step over Array mehtod as objWin has no cells property, only an ActiveCell Property[/color]
    [color=blue]Dim[/color] r [color=blue]As[/color] [color=blue]Long[/color], c [color=blue]As[/color] [color=blue]Long[/color] [color=lightgreen]'Row and column in Debinet imported data[/color]
            [color=blue]Dim[/color] DumpColumn [color=blue]As[/color] [color=blue]Long[/color] [color=lightgreen]'Column of Master Dump[/color]
                [color=blue]Dim[/color] Headr [color=blue]As[/color] Long [color=lightgreen]'Heading Row, (1 to 20)[/color]
        [color=blue]For[/color] r = 21 [color=blue]To[/color] lDbNr   [color=lightgreen]'Each debinet imported row. -20 must bbe used as starts at 1 due to the capture method[/color]
           [color=blue]If[/color] wksL2.Cells(r, 1).Value <> "" [color=blue]Then[/color] [color=lightgreen]'Efficiently only goint further if there is a Nutrition from Food Product[/color]
            [color=blue]For[/color] DumpColumn = 8 [color=blue]To[/color] lc [color=blue]Step[/color] 2 [color=lightgreen]'Go along each Master DumpColumn[/color]
                [color=lightgreen]'For Headr = 1 To 20 'Going throght the Headings...[/color]
[color=lightgreen]'                    If wksL2.Cells(r, 1).Value = wksDump.Cells(Headr, DumpColumn).Value Then 'Have heading match condition[/color]
                     [color=blue]On[/color] [color=blue]Error[/color] [color=blue]Resume[/color] [color=blue]Next[/color] [color=lightgreen]'If the next line errors we carry on[/color]
                     [color=blue]If[/color] Application.WorksheetFunction.Match(wksL2.Cells(r, 1).Value, wksDump.Columns(DumpColumn), 0) = -1234 [color=blue]Then[/color] [color=lightgreen]' This will error for any match indicie other than 1 , 2  , 3..... etc..[/color]
                     [color=lightgreen]'here we "carry on" at the "next" -- but there is nothing here so we go to end If[/color]
                     [color=blue]Else[/color] [color=lightgreen]'We come here if match "worked" but did not return the number -1234[/color]
                        [color=blue]If[/color] wksDump.Cells(ARow, DumpColumn).Value = "" [color=blue]Then[/color]  [color=lightgreen]'Case empty cell, no entry yet[/color]
                        [color=blue]Let[/color] wksDump.Cells(ARow, DumpColumn).Value = wksL2.Cells(r, 4).Value [color=lightgreen]'Important match condition so put in Forth column In appropriate colum indiciee for output[/color]
                        [color=blue]Else[/color] [color=lightgreen]'Presumably an entry is already there, and we already know we have a debinet entry, so as a first approximation put the average in[/color]
                        [color=blue]Let[/color] wksDump.Cells(ARow, DumpColumn).Value = Application.WorksheetFunction.Round((wksDump.Cells(ARow, DumpColumn).Value + wksL2.Cells(r, 4).Value) / 2, 7)
                        [color=blue]End[/color] [color=blue]If[/color]
                     [color=blue]End[/color] [color=blue]If[/color]
                [color=lightgreen]'Next Headr 'Try next heading for match[/color]
            [color=blue]Next[/color] DumpColumn [color=lightgreen]'back to next Master DumpColumn[/color]
           [color=blue]Else[/color] [color=lightgreen]'Not doing any sorting for no Nurition from Food Product[/color]
           [color=blue]End[/color] [color=blue]If[/color]
        [color=blue]Next[/color] r [color=lightgreen]'Go to next imported debinet Row[/color]
               
[color=lightgreen]'        'Msg Box check if all is well, if not put original enties back in. COMMENTED OUT FOR SPEED TESTS[/color]
[color=lightgreen]'        Dim Response As Integer 'In VBA Butons "yes is 6, 7 is "no"[/color]
[color=lightgreen]'        Response = MsgBox(prompt:="Is all OK?", Buttons:=vbYesNo, Title:="File Check") ' Displays a message box with the yes and no options.[/color]
[color=lightgreen]'        If Response = vbYes Then 'Do nothing, that is to say just carry on after End of If[/color]
[color=lightgreen]'        Else[/color]
'        Let RngFood.Value2 = ArrOrigEntries() 'Full repair!!':Let RngFoodAbKcal.Value2 = ArrOrigAbKcaEntries()'Repair only from Kcal
[color=lightgreen]'        End If[/color]
   
    wksDump.Cells(ARow, 1).Activate [color=lightgreen]'Just to be on the safe side in case run again without checking active cell[/color]
[color=blue]End[/color] [color=blue]Sub[/color] [color=lightgreen]'TransferDebiNetToDumpMostSpreadSheetMatchOnErrPair[/color]
 
 
 
 
[color=lightgreen]'[/color]
'
'
'
[color=blue]Sub[/color] TransferDebiNetToDumpMostSpreadsheetMatchOnErrPairShortenedHeaderColumn()
    [color=lightgreen]'Initial Sheet Names / File Names[/color]
    [color=blue]Dim[/color] wksL2 [color=blue]As[/color] Worksheet: [color=blue]Set[/color] wksL2 = ThisWorkbook.Worksheets("Leith2") [color=lightgreen]'Main Sheet for Imported Nutrients[/color]
    [color=blue]Dim[/color] FileName [color=blue]As[/color] String: [color=blue]Let[/color] FileName = ThisWorkbook.Name [color=lightgreen]'Need to do a bit of mucking about to get the window name[/color]
    [color=blue]Dim[/color] WindowFileName [color=blue]As[/color] [color=blue]String[/color] [color=lightgreen]'File name as typically seen displayed without last bit after dot[/color]
    [color=blue]Let[/color] WindowFileName = Left(FileName, (InStrRev(FileName, ".") - 1)) [color=lightgreen]'Take off the bit after the dot[/color]
    [color=blue]Dim[/color] objWin [color=blue]As[/color] Object: [color=blue]Set[/color] objWin = Windows("11 172x49ExtRowsGruppiertDumpAbDec2014ISSC") [color=lightgreen]'Mainly for Conveneince[/color]
   
    [color=lightgreen]'Make some back up initial data. - The Selected Food complete original Range and also The Selected original Food from KcalSet ## to last column wanted in Master to Fill in. (CU Vitamine)  range to include everything wanted.[/color]
    objWin.Activate [color=lightgreen]'ActiveCell below will not work without this[/color]
    [color=blue]Dim[/color] ARow [color=blue]As[/color] [color=blue]Long[/color], Acolumn [color=blue]As[/color] [color=blue]Long[/color], lc [color=blue]As[/color] [color=blue]Long[/color] [color=lightgreen]'Current Active Cell[/color]
    [color=blue]Let[/color] ARow = ActiveCell.Row: [color=blue]Let[/color] Acolumn = ActiveCell.Column [color=lightgreen]'Get cell coordinates for selected range. (For a range, the top left cell coordinates are returned)[/color]
    ActiveSheet.Range("A" & ARow & ":CU" & ARow & "").Select [color=lightgreen]'##CU (Vitamine) Extended selection range to include everything wanted.[/color]
    wksL2.Activate [color=lightgreen]'Mainly to see what is going on, and the next line still works!?[/color]
    [color=lightgreen]'        The Selected Food[/color]
    [color=blue]Dim[/color] RngFood [color=blue]As[/color] Range: [color=blue]Set[/color] RngFood = objWin.Selection
    [color=blue]Dim[/color] ArrOrigEntries() [color=blue]As[/color] Variant: [color=blue]Let[/color] ArrOrigEntries() = RngFood.Value2 [color=lightgreen]'Value2 is the underlying value, quickes and most accurate to get to http://www.excelforum.com/excel-new-users-basics/1058406-range-dimensioning-range-and-value-referencing-and-referring-to-arrays.html[/color]
    [color=blue]Dim[/color] ArrFood() [color=blue]As[/color] [color=blue]Variant[/color], ArrNut() [color=blue]As[/color] [color=blue]Variant[/color] [color=lightgreen]'CVhoose variant both to allow for "" and also to allow one liner throgh Range Object to work.[/color]
    [color=blue]Let[/color] ArrFood() = RngFood.Value2 [color=lightgreen]'VBA Capture possibility to bring in values in one liner[/color]
    [color=blue]Let[/color] lc = [color=blue]UBound[/color](ArrFood, 2) [color=lightgreen]': Let lc = 99'=CU[/color]
    [color=lightgreen]'        The Selected Food from Kcal[/color]
    objWin.Activate [color=lightgreen]'ActiveCell below will not work without this[/color]
    ActiveSheet.Range("H" & ARow & ":CU" & ARow & "").Select
    [color=blue]Dim[/color] RngFoodAbKcal [color=blue]As[/color] Range: [color=blue]Set[/color] RngFoodAbKcal = objWin.Selection
    [color=blue]Dim[/color] ArrOrigAbKcaEntries() [color=blue]As[/color] Variant: [color=blue]Let[/color] ArrOrigAbKcaEntries() = RngFoodAbKcal.Value2 [color=lightgreen]'Variant is not only necerssary for seeing Range Object, but also if it was for example a number than it will have 0s in place of empty cells[/color]
   
    [color=lightgreen]'Now main Loopin through spreadsheet, looking for match conditions, then writing in when match found[/color]
     [color=lightgreen]'The DebiNet imported range. May be advisable to set this Manually sometimes[/color]
    [color=blue]Dim[/color] lDbNr [color=blue]As[/color] [color=blue]Long[/color] [color=lightgreen]'The DebiNet imported range. May be advisable to set this Manually sometimes[/color]
    [color=blue]Let[/color] lDbNr = wksL2.Cells.Find(What:="*", After:=wksL2.Cells(1, 1), Lookat:=xlPart, LookIn:=xlFormulas, SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row [color=lightgreen]'Get last Row with entry anywhere for Sheet1. Method: You start at first cell then go backwards (which effectively starts at end of sheet), sercching for anything ( = * ) by rows, then get the row number. This allows for different excel versions with different available Row numbers) Just a different method that finds last row in sheet rather than row for last entry in particular cell. Better to use that here as we are not sure which columns are full[/color]
    [color=blue]Dim[/color] wksDump [color=blue]As[/color] Worksheet: [color=blue]Set[/color] wksDump = Workbooks("11 172x49ExtRowsGruppiertDumpAbDec2014ISSC.xlsx").Worksheets("Sheet1") [color=lightgreen]'Extra step over Array mehtod as objWin has no cells property, only an ActiveCell Property[/color]
    [color=blue]Dim[/color] r [color=blue]As[/color] [color=blue]Long[/color], c [color=blue]As[/color] [color=blue]Long[/color] [color=lightgreen]'Row and column in Debinet imported data[/color]
            [color=blue]Dim[/color] DumpColumn [color=blue]As[/color] [color=blue]Long[/color] [color=lightgreen]'Column of Master Dump[/color]
                [color=blue]Dim[/color] Headr [color=blue]As[/color] Long [color=lightgreen]'Heading Row, (1 to 20)[/color]
        [color=blue]For[/color] r = 21 [color=blue]To[/color] lDbNr   [color=lightgreen]'Each debinet imported row. -20 must bbe used as starts at 1 due to the capture method[/color]
           [color=blue]If[/color] wksL2.Cells(r, 1).Value <> "" [color=blue]Then[/color] [color=lightgreen]'Efficiently only goint further if there is a Nutrition from Food Product[/color]
            [color=blue]For[/color] DumpColumn = 8 [color=blue]To[/color] lc [color=blue]Step[/color] 2 [color=lightgreen]'Go along each Master DumpColumn[/color]
                [color=lightgreen]'For Headr = 1 To 20 'Going throght the Headings...[/color]
[color=lightgreen]'                    If wksL2.Cells(r, 1).Value = wksDump.Cells(Headr, DumpColumn).Value Then 'Have heading match condition[/color]
                     [color=blue]On[/color] [color=blue]Error[/color] [color=blue]Resume[/color] [color=blue]Next[/color] [color=lightgreen]'If the next line errors we carry on[/color]
                     [color=blue]If[/color] Application.WorksheetFunction.Match(wksL2.Cells(r, 1).Value, wksDump.Range((wksDump.Cells(1, DumpColumn)), (wksDump.Cells(21, DumpColumn))), 0) = -1234 [color=blue]Then[/color] [color=lightgreen]' This will error for any match indicie other than 1 , 2  , 3..... etc..[/color]
                     [color=lightgreen]'here we "carry on" at the "next" -- but there is nothing here so we go to end If[/color]
                     [color=blue]Else[/color] [color=lightgreen]'We come here if match "worked" but did not return the number -1234[/color]
                        [color=blue]If[/color] wksDump.Cells(ARow, DumpColumn).Value = "" [color=blue]Then[/color]  [color=lightgreen]'Case empty cell, no entry yet[/color]
                        [color=blue]Let[/color] wksDump.Cells(ARow, DumpColumn).Value = wksL2.Cells(r, 4).Value [color=lightgreen]'Important match condition so put in Forth column In appropriate colum indiciee for output[/color]
                        [color=blue]Else[/color] [color=lightgreen]'Presumably an entry is already there, and we already know we have a debinet entry, so as a first approximation put the average in[/color]
                        [color=blue]Let[/color] wksDump.Cells(ARow, DumpColumn).Value = Application.WorksheetFunction.Round((wksDump.Cells(ARow, DumpColumn).Value + wksL2.Cells(r, 4).Value) / 2, 7)
                        [color=blue]End[/color] [color=blue]If[/color]
                     [color=blue]End[/color] [color=blue]If[/color]
                [color=lightgreen]'Next Headr 'Try next heading for match[/color]
            [color=blue]Next[/color] DumpColumn [color=lightgreen]'back to next Master DumpColumn[/color]
           [color=blue]Else[/color] [color=lightgreen]'Not doing any sorting for no Nurition from Food Product[/color]
           [color=blue]End[/color] [color=blue]If[/color]
        [color=blue]Next[/color] r [color=lightgreen]'Go to next imported debinet Row[/color]
               
[color=lightgreen]'        'Msg Box check if all is well, if not put original enties back in. COMMENTED OUT FOR SPEED TESTS[/color]
[color=lightgreen]'        Dim Response As Integer 'In VBA Butons "yes is 6, 7 is "no"[/color]
[color=lightgreen]'        Response = MsgBox(prompt:="Is all OK?", Buttons:=vbYesNo, Title:="File Check") ' Displays a message box with the yes and no options.[/color]
[color=lightgreen]'        If Response = vbYes Then 'Do nothing, that is to say just carry on after End of If[/color]
[color=lightgreen]'        Else[/color]
'        Let RngFood.Value2 = ArrOrigEntries() 'Full repair!!':Let RngFoodAbKcal.Value2 = ArrOrigAbKcaEntries()'Repair only from Kcal
[color=lightgreen]'        End If[/color]
   
    wksDump.Cells(ARow, 1).Activate [color=lightgreen]'Just to be on the safe side in case run again without checking active cell[/color]
[color=blue]End[/color] [color=blue]Sub[/color] [color=lightgreen]'TransferDebiNetToDumpMostSpreadSheetMatchOnErrPairShortenedHeaderColumn[/color]
 
 
[color=blue]Sub[/color] Timers() [color=lightgreen]'SubRoutine to call Timer Functions and Subroutines under test and display results.[/color]
Application.ScreenUpdating = [color=blue]False[/color] [color=lightgreen]'Not necerssary but speeds things up a bit and is usually done so do it consistantly here in all tests. (Turns screen updating off. Good to edit out for Debuging Purposes.[/color]
[color=blue]On[/color] [color=blue]Error[/color] [color=blue]GoTo[/color] TheEnd [color=lightgreen]'If anything goes wrong go to the End instead of crashing. Useful to Edit out for Debuging[/color]
    [color=blue]Dim[/color] StartMTTime [color=blue]As[/color] [color=blue]Long[/color], StartVBATime [color=blue]As[/color] [color=blue]Long[/color] [color=lightgreen]'times in seconds at start of a run (Long is a Big whole Number limit (-2,147,483,648 to 2,147,483,647) -Most smaller numbers, Byte, Integer, Single are converted in computer to long so no advantage of Dim to smaller Type here) >>> Long is a Big whole Number limit (-2,147,483,648 to 2,147,483,647) If you need some sort of validation the value should only be within the range of a Byte/Integer otherwise there's no point using anything but Long.--upon/after 32-bit, Integers (Short) need converted internally anyways, so a Long is actually faster. http://www.mrexcel.com/forum/excel-questions/803662-byte-backward-loop-3.html[/color]
    [color=blue]Dim[/color] MTTime [color=blue]As[/color] [color=blue]Long[/color], VBATime [color=blue]As[/color] [color=blue]Long[/color] [color=lightgreen]'Run times given from Timer Functions[/color]
    [color=blue]Let[/color] MTTime = 0 [color=lightgreen]'Could leave this out, but good[/color]
    [color=blue]Let[/color] VBATime = 0 [color=lightgreen]'Practice to put it in[/color]
    [color=blue]Dim[/color] Iteration [color=blue]As[/color] [color=blue]Long[/color], MaxIteration [color=blue]As[/color] [color=blue]Long[/color] [color=lightgreen]'Variable used in avaraging a few runs[/color]
    [color=blue]Let[/color] MaxIteration = 1000 [color=lightgreen]'Set here the nimber of runs that you want.[/color]
      [color=blue]Call[/color] TransferDebiNetToDumpArrays [color=lightgreen]'Often good to do  it initially once before time runs. Sometimes on the first run things are done extra[/color]
      [color=lightgreen]'Call TransferDebiNetToDumpMostSpreadsheet[/color]
      [color=lightgreen]'Call TransferDebiNetToDumpMostSpreadsheetMatchOnErrPair[/color]
      [color=lightgreen]'Call TransferDebiNetToDumpMostSpreadsheetMatchOnErrPairShortenedHeaderColumn[/color]
     
      [color=blue]For[/color] Iteration = 1 [color=blue]To[/color] MaxIteration [color=lightgreen]'Run as many times as specified.[/color]
      [color=blue]Let[/color] StartMTTime = MicroTimer [color=lightgreen]'Function Code from Charley Williams[/color]
      [color=blue]Let[/color] StartVBATime = VBATimer [color=lightgreen]'Typical VBA Timer() Function code[/color]
      [color=blue]Call[/color] TransferDebiNetToDumpArrays
      [color=lightgreen]'Call TransferDebiNetToDumpMostSpreadsheet[/color]
      [color=lightgreen]'Call TransferDebiNetToDumpMostSpreadsheetMatchOnErrPair[/color]
      [color=lightgreen]'Call TransferDebiNetToDumpMostSpreadsheetMatchOnErrPairShortenedHeaderColumn[/color]
 
      [color=blue]Let[/color] MTTime = (MTTime + (MicroTimer - StartMTTime)) [color=lightgreen]'Total times so[/color]
      [color=blue]Let[/color] VBATime = (VBATime + (VBATimer - StartVBATime)) [color=lightgreen]'far.[/color]
      [color=blue]Next[/color] Iteration 'Go and do another run(s)
    MsgBox "Micro Timer " & (MTTime) / MaxIteration & " Seconds" & vbCr & _
           "VBA Timer " & (VBATime) / MaxIteration & " Seconds" [color=lightgreen]'Display avarage results.[/color]
 
Application.ScreenUpdating = [color=blue]True[/color] [color=lightgreen]'Turn screen "back on" or screen is "dead"[/color]
[color=blue]Exit[/color] [color=blue]Sub[/color] [color=lightgreen]'We stop code here assuming it worked (or at least did not crash!)[/color]
TheEnd: [color=lightgreen]'We come here on erroring rather than crashing. Anything that should be done before ending the macro should be done here, to make sure it will always be dine ecen if the code crashes![/color]
Application.ScreenUpdating = [color=blue]True[/color] [color=lightgreen]'Screen need to be turned back on or your screen will be "dead"!! Important to turn screen on here, incase anything goes wrong.[/color]
MsgBox (Err.Description) [color=lightgreen]'Print out error message in Message Box[/color]
[color=blue]End[/color] [color=blue]Sub[/color] [color=lightgreen]' Timers()[/color]
[color=blue]Function[/color] VBATimer()
[color=lightgreen]'Typical VBA Timer Program[/color]
    VBATimer = Timer [color=lightgreen]'Timer is a VBA Function that gives current time in seconds[/color]
[color=blue]End[/color] [color=blue]Function[/color] [color=lightgreen]' VBATimer()[/color]
[color=blue]Function[/color] MicroTimer() [color=blue]As[/color] [color=blue]Single[/color] 'Charley Williams Micro Timer Code
[color=lightgreen]'  http://www.mrexcel.com/forum/excel-questions/805285-copy-based-match-criteria-code-alternative-looping-2.html[/color]
[color=lightgreen]'  Jerry Sullivan  Speed up VBA code with VLOOKUP.  http://www.mrexcel.com/forum/excel-questions/745455-speed-up-visual-basic-applications-code-vlookup.html[/color]
[color=lightgreen]'  https://msdn.microsoft.com/en-us/library/ff700515(v=office.14).aspx[/color]
    [color=blue]Dim[/color] cyTicks1 [color=blue]As[/color] [color=blue]Currency[/color]
    [color=blue]Static[/color] cyFrequency [color=blue]As[/color] [color=blue]Currency[/color]
    [color=blue]Let[/color] MicroTimer = 0
      [color=blue]If[/color] cyFrequency = 0 [color=blue]Then[/color] getFrequency cyFrequency [color=lightgreen]' get ticks/sec[/color]
      getTickCount cyTicks1 [color=lightgreen]' get ticks[/color]
      [color=blue]If[/color] cyFrequency [color=blue]Then[/color] MicroTimer = cyTicks1 / cyFrequency ' calc seconds
  
[color=blue]End[/color] [color=blue]Function[/color] [color=lightgreen]'MicroTimer()[/color]




……………………………………………………………………………………………

P.s. 3. A vey last new idea fresh from that other Thread…
.Match with On Error: On Error Resume Next works. On Error GoTo only works once. Err.Clear
A CountIF variation ( Thanks TMS )

Simplified for the simple original Post #1 Example
<font face=Calibri><SPAN style="color:#00007F">Sub</SPAN> BringProductAndItsNutritionValuesIntoMainFileAbbrev3()<br><SPAN style="color:#00007F">Let</SPAN> MainFile = "MrExcelSortBeispielMainFile2007.xlsm"<br><SPAN style="color:#00007F">Let</SPAN> InputFile = "MrExcelSortBeispielFileToBeInputInMainFile2007.xlsx"<br><br><SPAN style="color:#00007F">For</SPAN> j = 1 <SPAN style="color:#00007F">To</SPAN> 40<br>    <SPAN style="color:#00007F">For</SPAN> x = 1 <SPAN style="color:#00007F">To</SPAN> 24<br>                  <SPAN style="color:#00007F">Let</SPAN> CntsIf = Application.WorksheetFunction.CountIf(Windows(MainFile).ActiveSheet.Columns(x), Windows(InputFile).ActiveSheet.Cells(j, 1).Value) <SPAN style="color:#007F00">'We "Count If" string in second argument is in the Array or Range of the first argument. And it does not seem to count empty cells</SPAN><br>                    <SPAN style="color:#00007F">If</SPAN> CntsIf <> 0 <SPAN style="color:#00007F">Then</SPAN> <SPAN style="color:#007F00">'If count is 1, 2 , 3 ...etc then we have match or matches..so...</SPAN><br>                    <SPAN style="color:#00007F">Let</SPAN> Windows(MainFile).ActiveSheet.Cells(ActiveCell.Row, x).Value = Windows(InputFile).ActiveSheet.Cells(j, 2).Value<br>                    <SPAN style="color:#00007F">Else</SPAN> <SPAN style="color:#007F00">'No Heading Match condition, do Nothing (redundant code)</SPAN><br>                    <SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">If</SPAN><br>    <SPAN style="color:#00007F">Next</SPAN> x<br><SPAN style="color:#00007F">Next</SPAN> j<br><SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">Sub</SPAN></FONT>
 
Upvote 0
You must log in or register to reply here.

Similar threads

E
  • Question Question
Adding a custom message.
Replies
1
Views
633
Micron
M
E
  • Question Question
VBA code clean up
Replies
9
Views
495
mumps
mumps
GMC The Macro Man
  • Question Question
Clear Data without VBA
2
Replies
12
Views
3K
mumps
mumps
M
  • Question Question
Help with FilterXML formula
Replies
0
Views
1K
montex01
M
J
  • Question Question
Lookup a Column Range by Matching Heading
Replies
3
Views
392
jcoeng
J

Forum statistics

Threads
1,223,366
Messages
6,171,665
Members
452,416
Latest member
johnog

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top