Macro to Sort Coupons by Redeemer Number

I scan coupons with a desktop scanner into a giant folder and I'm trying to make this easier on myself if at all possible. I'm wondering if once I have the giant index of all the coupons if there isn't a way to come up with a macro to put the coupons into the correct column based on their four digit redeemer number.

Here is an example of the coupon data:

Column A Column B Column C, D, Column E
4/29/2014 15:10 C:\Users\Galena\Desktop\Coupons Folder\2014 Coupons\HB1005-3\HB2013203589_04-29-2014_15-10-55.pdf 1 HB2013203589
4/29/2014 15:10 C:\Users\Galena\Desktop\Coupons Folder\2014 Coupons\HB1005-3\HB2013249468_04-29-2014_15-10-55.pdf 1 HB2013249468
4/29/2014 15:10 C:\Users\Galena\Desktop\Coupons Folder\2014 Coupons\HB1005-3\HB2013203553_04-29-2014_15-10-55.pdf 1 HB2013203553


The HB1005 is the redeemer number which will be found in column B. HB2013203589 etc. are the coupon numbers in column B and E (the same). I want to take all coupon numbers associated with each redeemer number and put them in a separate spreadsheet that has redeemer numbers listed at the top of each worksheet. I'm attaching that file.

The redeemer numbers (called FMNP #s) are each in column A2 of the worksheet and will always be there. So what I want is if 1005 is in A2, the macro will go to the next blank column in the worksheet and post all of the coupon numbers in that column, starting with cell 5.test coupon macro data.xlsm

Can anyone help? Thanks in advance!

Hi Norie - the data should be in sheets 2, 3, and 4. I left the summary blank since we can't share the redeemer's personal info.

~ Galena

Does this help?

Sub Mamagregoryaazz()
Dim rcell As Range
Dim x As String
Dim Z As String
Dim y As Long
Dim ws As Worksheet
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Sheets.Add.Name = "Raw Data2"
Sheets("Raw Data").UsedRange.Copy Sheets("Raw Data2").Range("A1")
For Each rcell In Sheets("Raw Data2").Range("B1:B" & Range("B" & Rows.count).End(3)(1).Row)
    rcell.Replace "C:\Users\Galena\Desktop\Coupons Folder\2014 Coupons\HB", "", xlPart
    rcell.Value = Left(rcell, 4)
    x = rcell.Value
Next rcell
For Each ws In ActiveWorkbook.Worksheets
    If ws.Name <> "Summary" And ws.Name <> "Vouchering Database" And ws.Name <> "Raw Data" And ws.Name <> "Raw Data2" Then
        If Right(ws.Range("A2"), 4) = x Then
            ws.Activate
            Exit For
        End If
    End If
Next ws
Range("A3").Select
Do Until ActiveCell.Value = ""
    ActiveCell.offset(, 1).Select
Loop
y = ActiveCell.Column
Z = ActiveSheet.Name
Cells(4, y).Value = CDate(Sheets("Raw Data2").Range("A1"))
Sheets("Raw Data2").Activate
For i = Range("E" & Rows.count).End(3)(1).Row To 1 Step -1
    Range("E" & i).Copy Sheets(Z).Cells(Rows.count, y).End(3)(2)
Next i
Sheets(Z).Columns(y + 2).Copy
Sheets(Z).Cells(1, y).PasteSpecial xlPasteFormats
Application.DisplayAlerts = False
Sheets("Raw Data2").Delete
Application.DisplayAlerts = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub

Hmm... I tried running it and it looked like it was doing something but then nothing happened.

I may not understand what you want too happen. It takes your Raw Data Sheet and looks for the 1005. If it matches a worksheet where Range("A2") has that value then it copies the cells in Column E too the next available Column of the found worksheet? In your sample the Worksheet is Rochester Public Market. Not sure if that is what you are trying too do.

No - I'm sorry I'm not being clear. It seems this is complicated to explain. lol. What I am trying to do is set up two macros to automate this. The second half is the one you already did for me on another thread (TYVM!). That second macro takes all the coupons and lists them according to their voucher number. With the first macro I am hoping to automate the process of getting the scanned coupons into all those columns. So you can imagine the columns all blank but waiting for data from that list that says "raw data." I want to take that raw data and match a giant list of coupons belonging to many different spreadsheets (it may have data from both scalzo, wagner, and rochester on the example spreadsheet). So I will scan all the coupons into folders labeled with their FMNP or redeemer number and then put them into the "raw data." It will be much longer than 3 lines. I want the macro to then look at the giant list of all the coupons and their folders and the put the coupons that belong to each redeemer scalzo etc. into the next blank column in their worksheet. That way the coupons scanned in previous weeks are still there. Please tell me this makes sense? lol Trying my best to explain.

Maybe it was in triplicate because I ran the macro more than once. I should probably refrain from doing these kinds of things after lunch lol.

I tried running it again with 10 coupons assigned to either redeemer/FMNP # 1234 (Scalzo), 2345 (Wagner), or 1005 (Rochester) and all 10 coupons went into column C of the Rochester one. I want the macro to check all worksheets for the given redeemer numbers and put the coupons into the next blank column according to that - not just for 1005 but for each number there if that makes sense.

What does your "Raw Data" sheet look like?

This was the raw data I tried:

4/30/2014 13:41 C:\Users\Galena\Desktop\Coupons Folder\2014 Coupons\HB1234\HB2013203535.pdf 1 HB2013203535
4/30/2014 13:41 C:\Users\Galena\Desktop\Coupons Folder\2014 Coupons\HB1234\HB2013203534.pdf 1 HB2013203534
4/30/2014 13:41 C:\Users\Galena\Desktop\Coupons Folder\2014 Coupons\HB1234\HB2013203533.pdf 1 HB2013203533
4/30/2014 13:41 C:\Users\Galena\Desktop\Coupons Folder\2014 Coupons\HB2345\HB2013203532.pdf 1 HB2013203532
4/30/2014 13:41 C:\Users\Galena\Desktop\Coupons Folder\2014 Coupons\HB2345\HB2013203531.pdf 1 HB2013203531
4/30/2014 13:41 C:\Users\Galena\Desktop\Coupons Folder\2014 Coupons\HB2345\HB2013203530.pdf 1 HB2013203530
4/30/2014 13:41 C:\Users\Galena\Desktop\Coupons Folder\2014 Coupons\HB2345\HB2013203529.pdf 1 HB2013203529
4/30/2014 13:41 C:\Users\Galena\Desktop\Coupons Folder\2014 Coupons\HB2345\HB2013203528.pdf 1 HB2013203528
4/30/2014 13:41 C:\Users\Galena\Desktop\Coupons Folder\2014 Coupons\HB1005\HB2013203527pdf 1 HB2013203527
4/30/2014 13:41 C:\Users\Galena\Desktop\Coupons Folder\2014 Coupons\HB1005\HB2013203526.pdf 1 HB2013203526

Can you provide a sheet with your Raw Data in it. Depicting how it would look when it is downloaded to the file. (ie what would be in what Column, how it is delimited ect.)

I took off the date and time since that appears on the left also but that shouldn't change anything should it? The only other thing that is different is the HB1234 doesn't have a -3 after it. The -3 referred to the third time I scanned coupons with that code so that part can be ignored.

Yes, as soon as my boss stops buggin me! :P Here it is. I left the other data in but the last worksheet is the new raw data I was trying. When you run the macro you get this in Column C of Rochester:

30/Apr/14
HB2013203526
HB2013203527
HB2013203528
HB2013203529
HB2013203530
HB2013203531
HB2013203532
HB2013203533
HB2013203534
HB2013203535

(all 10 coupons)

test coupon macro data with raw data 4-30.xlsm

Try:

Sub Mamagregoryaazzzz()
Dim rcell As Range
Dim x As String
Dim Z As String
Dim y As Long
Dim ws As Worksheet
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Sheets.Add.Name = "Raw Data2"
Sheets("Raw Data").UsedRange.Copy Sheets("Raw Data2").Range("A1")
For Each ws In ActiveWorkbook.Worksheets
    If ws.Name = "Summary" Or ws.Name = "Vouchering Database" Or ws.Name = "Raw Data" Or ws.Name = "Raw Data2" Then
        GoTo zz
    Else
        ws.Activate
        Z = ActiveSheet.Name
        Range("A3").Select
            Do Until ActiveCell.Value = ""
                 ActiveCell.offset(, 1).Select
            Loop
        y = ActiveCell.Column
        x = Right(ws.Range("A2"), 4)
            For Each rcell In Sheets("Raw Data2").Range("B1:B" & Sheets("Raw Data2").Range("B" & Rows.count).End(3)(3).Row)
                rcell.Replace "C:\Users\Galena\Desktop\Coupons Folder\2014 Coupons\HB", "", xlPart
                rcell.Value = Left(rcell, 4)
                If rcell.Value = x Then
                ws.Cells(4, y).Value = CDate(Sheets("Raw Data2").Range("A1"))
                ws.Cells(Rows.count, y).End(3)(2).Value = rcell.offset(, 3).Value
                End If
            Next rcell
    End If
    ws.Columns(y + 2).Copy
    ws.Cells(1, y).PasteSpecial xlPasteFormats
zz:
Next ws
Application.DisplayAlerts = False
Sheets("Raw Data2").Delete
Application.DisplayAlerts = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub

It worked! Is there something in there that puts the date above the coupons? I noticed it put 30/Apr/14 in both yesterday and today. Is there something I should be changing in the macro to get today's date?
And can I get your address to send you a thank you card? (seriously lol! - this will be a HUGE help since I do this 6 months out of the year).

You're welcome. Glad to help out and thanks for the feedback.

Try:

Sub Mamagregoryaazzzz()
Dim rcell As Range
Dim x As String
Dim Z As String
Dim y As Long
Dim ws As Worksheet
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Sheets.Add.Name = "Raw Data2"
Sheets("Raw Data").UsedRange.Copy Sheets("Raw Data2").Range("A1")
For Each ws In ActiveWorkbook.Worksheets
    If ws.Name = "Summary" Or ws.Name = "Vouchering Database" Or ws.Name = "Raw Data" Or ws.Name = "Raw Data2" Then
        GoTo zz
    Else
        ws.Activate
        Z = ActiveSheet.Name
        Range("A3").Select
            Do Until ActiveCell.Value = ""
                 ActiveCell.offset(, 1).Select
            Loop
        y = ActiveCell.Column
        x = Right(ws.Range("A2"), 4)
            For Each rcell In Sheets("Raw Data2").Range("B1:B" & Sheets("Raw Data2").Range("B" & Rows.count).End(3)(3).Row)
                rcell.Replace "C:\Users\Galena\Desktop\Coupons Folder\2014 Coupons\HB", "", xlPart
                rcell.Value = Left(rcell, 4)
                If rcell.Value = x Then
                ws.Cells(4, y).Value = Date
                ws.Cells(Rows.count, y).End(3)(2).Value = rcell.offset(, 3).Value
                End If
            Next rcell
    End If
    ws.Columns(y + 2).Copy
    ws.Cells(1, y).PasteSpecial xlPasteFormats
zz:
Next ws
Application.DisplayAlerts = False
Sheets("Raw Data2").Delete
Application.DisplayAlerts = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub

Beautiful - yes it worked. Is there anything I need to change in there or will it know tomorrows date &c? I guess I will have to wait until tomorrow to check! hehe

A couple of follow ups:

~Is there anyway to get it to put the Voucher Numbers above the date? So in other words the dates are in row 4, the voucher numbers are in 3. I will be working on each voucher number for maybe two weeks or so so all the coupons that I scan in that two weeks will need to have "VOUCHER #" so VOUCHER 1, VOUCHER 2 or whichever number I am working on. I can manually add them after running this, but I'm guessing you can put that in also? And then I'd just have to go into the macro and change that once I switched to the next number. I think it needs to be in caps for the other macro to read it.

~This one may be more complicated and if so, ignore: Is there any way for the macro to check and see if any of the items in the "raw data" do NOT have a worksheet to put the coupons in? So for example if there was a folder there in the raw data with HB1005 (cell B) but no worksheet for Rochester to put it into. Kind of like an error report of sorts?

Also, how did you get so smart about this stuff? I am homeschooling my 12 year old son next year (because he has grown to be too smart for public school!) and he already knows as much about html and css as I do but nothing about excel and macros - any resources you'd recommend for learning this stuff?

See if this modification handles your Voucher issue:

Sub Mamagregoryaazzzz()
Dim rcell As Range
Dim q As Variant
Dim x As String
Dim Z As String
Dim y As Long
Dim ws As Worksheet
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Sheets.Add.Name = "Raw Data2"
Sheets("Raw Data").UsedRange.Copy Sheets("Raw Data2").Range("A1")
For Each ws In ActiveWorkbook.Worksheets
    If ws.Name = "Summary" Or ws.Name = "Vouchering Database" Or ws.Name = "Raw Data" Or ws.Name = "Raw Data2" Then
        GoTo zz
    Else
        ws.Activate
        Z = ActiveSheet.Name
        Range("A3").Select
            Do Until ActiveCell.Value = ""
                 ActiveCell.offset(, 1).Select
            Loop
        y = ActiveCell.Column
        x = Right(ws.Range("A2"), 4)
            For Each rcell In Sheets("Raw Data2").Range("B1:B" & Sheets("Raw Data2").Range("B" & Rows.count).End(3)(3).Row)
                rcell.Replace "C:\Users\Galena\Desktop\Coupons Folder\2014 Coupons\HB", "", xlPart
                rcell.Value = Left(rcell, 4)
                If rcell.Value = x Then
                q = Right(ws.Cells(3, y - 1), 1)
                ws.Cells(3, y).Value = Left(ws.Cells(3, y - 1), 7) & " " & q + 1
                ws.Cells(4, y).Value = Date
                ws.Cells(Rows.count, y).End(3)(2).Value = rcell.offset(, 3).Value
                End If
            Next rcell
    End If
    If y > 2 Then
    ws.Columns(y - 2).Copy
    ws.Cells(1, y).PasteSpecial xlPasteFormats
    Else
    ws.Cells(3, 1).Copy
    ws.Cells(3, 2).PasteSpecial xlPasteFormats
    End If
zz:
Next ws
Application.DisplayAlerts = False
Sheets("Raw Data2").Delete
Application.DisplayAlerts = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub

Your last request, I think is a bit more complicated than I can help with.

As for learning resources see below some of my recommendations:

John Walkenbach's Power Programming with Excel VBA series (J-Walk & Associates Home Page)

And this list was compiled by a lad named Hiker95 - I find it very useful;

1.	Training / Books / Sites as of 1/30/2014

What Is VBA?
VBA is an acronym for Visual Basic for Applications. VBA should not be confused with VB, which is standard Visual Basic. Visual Basic for Applications is a programming feature designed by Microsoft for use with their Microsoft Office

MrExcel's Products: Books, CDs, Podcasts Discuss topics related to Holy Macro! Products: Learn Excel from MrExcel, VBA and Macros for Microsoft Excel,Holy Macro! It's 2500 VBA Examples CD, Guerilla Data Analysis Using Microsoft Excel and Excel Knowledge Base CD and the MrExcel Podcasts.
http://www.mrexcel.com/forum/mrexcels-products-books-cds-podcasts/

There are over 1800 Excel videos/tutorials here:
http://www.youtube.com/user/ExcelIsFun

Getting Started with VBA. 
http://www.datapigtechnologies.com/ExcelMain.htm

If you are serious about learning VBA try 
http://www.add-ins.com/vbhelp.htm

Excel Tutorials and Tips - VBA - macros - training
http://www.mrexcel.com/articles.shtml

Free VBA Course
http://www.excel-pratique.com/en/vba.php

Excel 2007 VBA materials to learn here:
http://www.worldbestlearningcenter.c...erstanding.htm

Here's a good primer on the scope of variables.
http://www.cpearson.com/excel/scope.aspx

Using Variables in Excel VBA Macro Code
http://www.ozgrid.com/VBA/variables.htm

See David McRitchie's site if you just started with VBA
http://www.mvps.org/dmcritchie/excel/getstarted.htm

What is a VBA Module and How is a VBA Module Used?
http://www.emagenit.com/VBA%20Folder...vba_module.htm

Events And Event Procedures In VBA
http://www.cpearson.com/excel/Events.aspx

Here is a good introductory tutorial using a VBA Class:
http://www.cpearson.com/excel/classes.aspx

Ron's Excel Tips
http://www.rondebruin.nl/tips.htm

Ron de Bruin's Mail from Excel and make/mail PDF files (Windows)
http://www.rondebruin.nl/win/section1.htm

Anthony's Excel VBA Page - Excel Application - Excel Consultant - Excel Consulting (see 3 tutorials in Excel VBA Basic Tutorial Series)

BET: Microsoft Excel Visual Basic

Debugging VBA
Debug Excel VBA Macro Code
TechBookReport - Debugging Excel VBA Code

Start at the beginning...

Creating An XLA Add-In For Excel, Writing User Defined Functions In VBA
http://www.cpearson.com/excel/createaddin.aspx

Creating custom functions
http://office.microsoft.com/en-us/ex...117011033.aspx

Writing Your First VBA Function in Excel
http://www.exceltip.com/st/Writing_Y...Excel/631.html

VBA for Excel (Macros)
http://www.excel-vba.com/excel-vba-contents.htm

Excel Macros Tutorial
http://www.excel-vba.com/excel-vba-contents.htm

Excel Macros & Programming
http://www.excel-vba.com/index.htm

VBA Lesson 11: VBA Code General Tips and General Vocabulary
http://www.excel-vba.com/vba-code-2-1-tips.htm

Excel VBA -- Adding Code to a Workbook
http://www.contextures.com/xlvba01.html

Beyond Excel's recorder

Helpful as a simple concise reference for the basics, and, using the macro recorder is endlessly powerful.
http://www.techonthenet.com/excel/cells/index.php

Learn to debug: 
http://www.cpearson.com/excel/debug.htm

How To: Assign a Macro to a Button or Shape
http://peltiertech.com/WordPress/how...tton-or-shape/

User Form Creation
http://www.contextures.com/xlUserForm01.html

When To Use a UserForm & What to Use a UserForm For
http://www.ozgrid.com/Excel/free-tra...ba2lesson2.htm

Excel Tutorials / Video Tutorials - Functions
http://www.contextures.com/xlFunctions02.html

How to insert Buttons, radio buttons and check boxes in Excel
http://www.bing.com/videos/search?q=...xcel&FORM=VDRE

INDEX MATCH - Excel Index Function and Excel Match Function
http://www.contextures.com/xlFunctions03.html

Multi or two way vlook up and index match tutorial
http://www.get-digital-help.com/

Excel Data Validation
http://www.contextures.com/xlDataVal08.html#Larger
http://www.contextures.com/excel-dat...ation-add.html

Excel -- Data Validation -- Create Dependent Lists
http://www.contextures.com/xlDataVal02.html

Your Quick Reference to Microsoft Excel Solutions
http://www.xl-central.com/index.html

New! Excel Recorded Webinars
http://www.datapigtechnologies.com/ExcelMain.htm

Fuzzy Matching - new version plus explanation

Programming The VBA Editor - Created by Chip Pearson at Pearson Software Consulting LLC
This page describes how to write code that modifies or reads other VBA code.
http://www.cpearson.com/Excel/vbe.aspx

VBA and Macros for Microsoft Excel, by Bill Jelen "Mr.Excel" and Tracy Syrstad

Excel Hacks 100 Industrial-Strength Tips & Tools, by David & Traina Hawley

VBA and Macros for Microsoft Excel 2007, by Bill Jelen "Mr.Excel" and Tracy Syrstad

John Walkenbach's power programming with Excel books.

Excel 2010 Power Programming with VBA, Mr. Spreadsheet's Bookshelf

by Stephen/ Bovey, Rob/ Green, John Bullen (Paperback - Feb 11, 2005)
Professional Excel Development

by Rob Bovey, Stephen Bullen, John Green, and Robert Rosenberg (Paperback - Sep 26, 2001)
Excel 2002 VBA: Programmers Reference

"Professional Excel Development" by Rob Bovey, Dennis Wallentin, Stephen Bullen, & John Green

DonkeyOte: My Recommended Reading, Volatility
http://www.decisionmodels.com/calcsecretsi.htm

Sumproduct
http://www.xldynamic.com/source/xld.SUMPRODUCT.html

Arrays
VBA Array Basics
http://www.cpearson.com/excel/VBAArrays.htm
http://www.xtremevbtalk.com/showthread.php?t=296012
http://www.vbtutor.net/vba/vba_chp21.htm

Array Dimensions in Visual Basic - Working with Dimensions (code and graphics)
http://msdn.microsoft.com/en-us/libr...(v=VS.80).aspx

Shortcut Keys in Excel 2000 through 2007

Pivot Intro
http://peltiertech.com/Excel/Pivots/pivotstart.htm
Office 2010 Class #36: Excel PivotTables Pivot Tables 15 examples (Data Analysis) - YouTube
http://www.youtube.com/watch?v=qMGILHiLqr0
Getting Started with Pivot Tables
http://www.contextures.com/xlPivot01.html#Start
Overview of PivotTable and PivotChart reports
http://office.microsoft.com/en-gb/ex...010342752.aspx
Build a Pivot Table in Excel VBA
http://www.brainbell.com/tutorials/E...Excel_VBA.html

Email from XL - VBA
http://www.rondebruin.nl/sendmail.htm

Outlook VBA
http://www.outlookcode.com/article.aspx?ID=40

Excel Function Dictionary by Peter Noneley
http://www.xlfdic.com/
http://www.hoffits.com/

Function Translations
http://www.piuha.fi/excel-function-name-translation/

Dynamic Named Ranges
http://www.contextures.com/xlNames01.html

How to create Excel Dashboards
http://www.contextures.com/excel-dashboards.html
http://chandoo.org/wp/excel-dashboards/
http://chandoo.org/wp/management-dashboards-excel/
http://www.exceldashboardwidgets.com/
http://www.andypope.info/charts/gauge.htm 

Excel Dashboard / Scorecard Ebook
http://www.qimacros.com/excel-dashboard-scorecard.html

Mike Alexander from Data Pig Technologies
http://www.amazon.com/Excel-2007-Das...5564958&sr=1-1

Templates
http://www.cpearson.com/Excel/Topic.aspx
http://www.contextures.com/excel-tem...lf-scores.html
http://www.ozgrid.com/search/templates.htm

Microsoft Excel Cascading Listboxes Tutorial
http://www.youtube.com/watch?v=YAMvLJRwZdI

Date & Time stamping:
http://www.mcgimpsey.com/excel/timestamp.html

Get Formula / Formats thru custom functions:
http://dmcritchie.mvps.org/excel/formula.htm#GetFormat

A nice informative MS article "Improving Performance in Excel 2007"
http://msdn.microsoft.com/en-us/library/aa730921.aspx

Progress Meters
http://www.andypope.info/vba/pmeter.htm
http://www.xcelfiles.com/ProgressBar.html

How to convert text to numbers in Excel
http://support.microsoft.com/kb/291047

How to parse data from the web - Brett Fret has a video in YouTube
http://www.youtube.com/watch?v=6H7tBL97orE

And, as your skills increase, try answering threads on sites like:
http://www.mrexcel.com
http://www.excelforum.com
http://www.ozgrid.com
http://www.vbaexpress.com
http://www.excelfox.com

If you are willing to spend money for the training, then something here should work for you...
Amazon.com: excel tutorial dvd

Advanced Excel Training - Online Excel Course
http://www.udemy.com/advanced-excel/

That worked but it puts the next available number for the voucher rather than a specific number (so for sheets that had voucher 1 and 2 it put "VOUCHER 3" and for those who had 1 2 and 3 it put "VOUCHER 4") - I want to set it to a specific number for example "VOUCHER 31" and everything goes under that same voucher number until I change the macro to "VOUCHER 32." Even if there is more than one column in the same sheet with that voucher number on it.

Also found another potential bug - the one that has a redeemer/fmnp number of 0333 isn't going in since the "raw data 2" pastes it as 333. That's an Excel formatting thing but how can I set the formatting for Raw Data 2 to text since I can't see it until after the macro starts?

And thanks for the link I will take a look at those. Must be good info if he has hiker in the username - I run a small nonprofit in my spare time called Hikers for the Homeless.

Yes that input box works really well. Perfect! I hate to bug you again but I thought I could create one index file with the scanner software that I have - it seems I can only create index files for the individual folders.

So instead of the 4/30/2014 13:41 C:\Users\Galena\Desktop\Coupons Folder\2014 Coupons\HB1234\HB2013203535.pdf 1 HB2013203535 data setup I would have:


4/30/2014 13:41 C:\Users\Galena\Desktop\Coupons Folder\2014 Coupons\May1\HB2013203535_HB1055.pdf 1 HB2013203535

Is there any way to modify the macro for that format? I tried to look at the difference between the two to see where to change the positioning but I am a bit confused. That way I can pot all coupons from a day into a single folder and just append the redeemer # to the end of the coupon. So it will still be in cell b but in a different position. Otherwise I have to find a way to combine all those index files which I am finding difficult since they are csv files with the same name.

I had another idea too: what if instead of finding errors, the macro could highlight each cell on the raw data sheet after it places the coupons into the worksheet with that FMNP/redeemer #? Maybe that would be an easier way of checking for errors. Also, do you benefit in any way from threads being marked as solved? If not I could leave this open to see if anyone else bothered to read this far in lol and if they have an answer for it. Even if I have to manually check double check it will still be way faster than how I was doing it but if there's some way I can check for errors that would be awesome.

See if this helps?

Sub Mamagregoryaazzzz()
Dim rcell As Range
Dim x As String
Dim y As Long
Dim w As String
Dim ws As Worksheet
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
w = InputBox("Please Enter the Next Voucher No.")
Sheets.Add.Name = "Raw Data2"
Sheets("Raw Data").UsedRange.Copy Sheets("Raw Data2").Range("A1")
For Each ws In ActiveWorkbook.Worksheets
    If ws.Name = "Summary" Or ws.Name = "Vouchering Database" Or ws.Name = "Raw Data" Or ws.Name = "Raw Data2" Then
        GoTo zz
    Else
        ws.Activate
        Range("A3").Select
            Do Until ActiveCell.Value = ""
                 ActiveCell.offset(, 1).Select
            Loop
        y = ActiveCell.Column
        x = Right(ws.Range("A2"), 4)
            For Each rcell In Sheets("Raw Data2").Range("B1:B" & Sheets("Raw Data2").Range("B" & Rows.count).End(3)(3).Row)
                rcell.Replace "C:\Users\Galena\Desktop\Coupons Folder\2014 Coupons\HB", "", xlPart
                rcell.Replace "C:\Users\Galena\Desktop\Coupons Folder\2014 Coupons\May1\HB2013203535_HB", "", xlPart
                rcell.Value = "'" & Left(rcell, 4)
                If rcell.Value = x Then
                ws.Cells(3, y).Value = Left(ws.Cells(3, y - 1), 7) & " " & w
                ws.Cells(4, y).Value = Date
                ws.Cells(Rows.count, y).End(3)(2).Value = rcell.offset(, 3).Value
                End If
            Next rcell
    End If
    If y > 2 Then
    ws.Columns(y - 2).Copy
    ws.Cells(1, y).PasteSpecial xlPasteFormats
    Else
    ws.Cells(3, 1).Copy
    ws.Cells(3, 2).PasteSpecial xlPasteFormats
    End If
zz:
Next ws
Application.DisplayAlerts = False
Sheets("Raw Data2").Delete
Application.DisplayAlerts = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub

Hmmm... it seemed like it was working but it only did one line of the raw data (stopped on cell B2 of the raw data).

Can you provide another sample with the changes you noted. One where it stops on B2?

I couldn't duplicate the error with your current sample. But this modification should produce an error sheet which has the codes which were not found. Hope that helps.

Sub Mamagregoryaazzzz()
Dim rcell As Range
Dim i As Long
Dim x As String
Dim y As Long
Dim w As String
Dim ws As Worksheet
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
w = InputBox("Please Enter the Next Voucher No.")
Sheets.Add.Name = "Raw Data2"
Sheets("Raw Data").UsedRange.Copy Sheets("Raw Data2").Range("A1")
For Each ws In ActiveWorkbook.Worksheets
    If ws.Name = "Summary" Or ws.Name = "Vouchering Database" Or ws.Name = "Raw Data" Or ws.Name = "Raw Data2" Then
        GoTo zz
    Else
        ws.Activate
        Range("A3").Select
            Do Until ActiveCell.Value = ""
                 ActiveCell.offset(, 1).Select
            Loop
        y = ActiveCell.Column
        x = Right(ws.Range("A2"), 4)
            For Each rcell In Sheets("Raw Data2").Range("B1:B" & Sheets("Raw Data2").Range("B" & Rows.count).End(3)(3).Row)
                rcell.Replace "C:\Users\Galena\Desktop\Coupons Folder\2014 Coupons\HB", "", xlPart
                rcell.Replace "C:\Users\Galena\Desktop\Coupons Folder\2014 Coupons\May1\HB2013203535_HB", "", xlPart
                rcell.Value = "'" & Left(rcell, 4)
                If rcell.Value = x Then
                ws.Cells(3, y).Value = Left(ws.Cells(3, y - 1), 7) & " " & w
                ws.Cells(4, y).Value = Date
                ws.Cells(Rows.count, y).End(3)(2).Value = rcell.offset(, 3).Value
                rcell.Interior.ColorIndex = 6
                End If
            Next rcell
    End If
    If y > 2 Then
    ws.Columns(y - 2).Copy
    ws.Cells(1, y).PasteSpecial xlPasteFormats
    Else
    ws.Cells(3, 1).Copy
    ws.Cells(3, 2).PasteSpecial xlPasteFormats
    End If
zz:
Next ws
With Sheets("Raw Data2")
    .Activate
    .Name = "Errors"
    .Columns(1).Delete
    .Columns("B:D").Delete
    .Range("A1").Value = "Codes Not Found"
End With
For i = Range("A" & Rows.count).End(3)(1).Row To 2 Step -1
    If Range("A" & i).Interior.ColorIndex = 6 Then Rows(i).Delete
Next i

Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub

Did you try replacing the code with the modified version in Post #31. Can you provide a sample where you are getting errors?

2014 FMHB Participant Redemptions Test.xlsm This is what I'm getting.

I still cannot reproduce the error with your current sample. However, I did notice that it did not pull all the data as intended. But that was because of how your downloaded "Raw Data" file is set-up.

See what happens with this one.

Sub Mamagregoryaazzzz()
Dim rcell As Range
Dim i As Long
Dim x As String
Dim y As Long
Dim w As String
Dim ws As Worksheet
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
On Error Resume Next
Application.DisplayAlerts = False
Sheets("Errors").Delete
Application.DisplayAlerts = True
On Error GoTo 0
w = InputBox("Please Enter the Next Voucher No.")
Sheets.Add.Name = "Raw Data2"
Sheets("Raw Data").UsedRange.Copy Sheets("Raw Data2").Range("A1")
For Each ws In ActiveWorkbook.Worksheets
    If ws.Name = "Summary" Or ws.Name = "Vouchering Database" Or ws.Name = "Raw Data" Or ws.Name = "Raw Data2" Then
        GoTo zz
    Else
        ws.Activate
        Range("A3").Select
            Do Until ActiveCell.Value = ""
                 ActiveCell.offset(, 1).Select
            Loop
        y = ActiveCell.Column
        x = Right(ws.Range("A2"), 4)
            For Each rcell In Sheets("Raw Data2").Range("B1:B" & Sheets("Raw Data2").Range("B" & Rows.count).End(3)(3).Row)
                rcell.Value = "'" & Left(Right(rcell, 8), 4)
                If rcell.Value = x Then
                ws.Cells(3, y).Value = Left(ws.Cells(3, y - 1), 7) & " " & w
                ws.Cells(4, y).Value = Date
                ws.Cells(Rows.count, y).End(3)(2).Value = rcell.offset(, 3).Value
                rcell.Interior.ColorIndex = 6
                End If
            Next rcell
    End If
    If y > 2 Then
    ws.Columns(y - 2).Copy
    ws.Cells(1, y).PasteSpecial xlPasteFormats
    Else
    ws.Cells(3, 1).Copy
    ws.Cells(3, 2).PasteSpecial xlPasteFormats
    End If
zz:
Next ws
With Sheets("Raw Data2")
    .Activate
    .Name = "Errors"
    .Columns(1).Delete
    .Columns("B:D").Delete
    .Range("A1").Value = "Codes Not Found"
End With
For i = Range("A" & Rows.count).End(3)(1).Row To 2 Step -1
    If Range("A" & i).Interior.ColorIndex = 6 Then Rows(i).Delete
Next i

Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub

Oops we crossed posts. Yes I think that version didn't save and I had an older version. I edited the post above to show the error I am getting.

When it gets to this part:


rcell.Replace "C:\Users\Galena\Desktop\Coupons Folder\2014 Coupons\May1\HB2013203535_HB", "", xlPart

It says out of range and when I select debug it highlights this section above:

Sheets("Raw Data").UsedRange.Copy Sheets("Raw Data2").Range("A1").

Can you provide the attachment? Do you have a Sheet "Raw Data" with no spaces?

Yes it worked. I can't see what was wrong with my data but this one worked so I will stick with it lol.

Glad to hear it worked for you, and thanks for the feedback. Please mark this thread as solved.

Lol yes I bet no one else will make it to the bottom of this! :P

Wow. I'm afraid I'll have too agree. Have a great weekend.

You also! I hope you will be stepping away from the computer to enjoy whatever else there is to do in Jersey. I've only been there once even though I live in NY. It was a nightmare family vacation with my ex to the Jersey Shore. Before the TV show lol.