Jump to content
News Ticker
  • Welcome to the Community
  • Use the forum to troubleshoot your Excel & VBA Problems
  • We will be launching a new website soon! www.ExcelWTF.com/Learn ! Join us to learn VBA from the ground up!
  • 0
GeeperZ

Find, copy, paste, find again, repeat

Question

Hi Everyone,

I'm very new to VBA & everything I have accomplished so far has been down to recording macros or blatant plagiarism!

 

The situation is this, hundreds of workbooks with data in them (that I need to maintain the integrity of) that I need to extract portions of (I'm using the excellent RDB Merge Add-In for this) & transpose into another sheet so that we can set up mail merge into Word.

 

The workbooks are consistently inconsistent, if you know what I mean, in that the data follows a similar format but may be located in different cells, Workbook A could have two records in it, Workbook B maybe over a hundred records etc., the number of rows a record occupies & the number of rows to the next record are variable.

 

Note: also posted on http://www.mrexcel.com/forum/excel-ques ... epeat.html

 

EDIT: Data removed by Caleeco. See Post #2 for OP's data set

 

So, a bit of Googling led me to various solutions but I can't make any of them work for me. I would like to search the 'Combine' sheet for 'Make' & copy the values from 1 cell to the right of 'Make', 10 cells down, into the 'Extract' sheet, then repeat until 'Make' is not found.

 

The code I have so far is from here (section 3), which I want to modify with the code below (recorded) so that the aim is achieved.

 

 

ActiveCell.Offset(0, 1).Range("A1:A10").Select
    Selection.Copy
    Sheets("Extract").Select
    Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=True
    ActiveCell.Offset(1, 0).Range("A1").Select
        Sheets("Combine Sheet").Select

 

Am I 'barking up the wrong tree' or is there a better way to do this? Would appreciate any help, however small.

Share this post


Link to post
Share on other sites

13 answers to this question

Recommended Posts

  • 0

Hi Geeperz, 

 

Apologies, I dont know why it stripped out that syntax! New board...got a few things to fix!  :oops: I just tested the code below, and it works on my end. The Code you uploaded wasnt working as the loop statement should be

Loop While rFound.Address  FirstAddress

 

Working code:

Sub TransposeData2()
Application.ScreenUpdating = False

Dim rFound As Range
Dim FirstAddress As String
Dim lC As Long 'Count variable for the rows

lC = 0
Worksheets("Combine Sheet").Activate
With Worksheets("Combine Sheet").Columns("C:C")
    Set rFound = .Find(What:="Make", After:=Range("C" & Rows.Count), LookIn:=xlValues, _
        lookat:=xlWhole, Searchorder:=xlByRows, Searchdirection:=xlNext, MatchCase:=False)

    If Not rFound Is Nothing Then 'Value has been found
        FirstAddress = rFound.Address
        lC = Worksheets("Extract").Range("A" & Rows.Count).End(xlUp).Row
        Do
            rFound.Select
            'Add post processing
            If rFound.Offset(0, 1) = vbNullString Then
                'There is some data missing
                Range(rFound.Offset(1, 1), rFound.Offset(1, 1).End(xlDown)).Copy
                Worksheets("Extract").Range("A" & lC).Offset(1, 1).PasteSpecial Paste:=xlValues, Transpose:=True
                lC = lC + 1
            Else
                Range(rFound.Offset(0, 1), rFound.Offset(0, 1).End(xlDown)).Copy
                Worksheets("Extract").Range("A" & lC).Offset(1, 0).PasteSpecial Paste:=xlValues, Transpose:=True
                lC = lC + 1
            End If
        
            Set rFound = .FindNext(After:=rFound)
        Loop While rFound.Address  FirstAddress
    Else 'Value has NOT been found
        Exit Sub
    End If
End With
Application.CutCopyMode = False
Application.ScreenUpdating = False
End Sub

 

Thanks for your patience

Regards

Caleeco

  • Like 1

Share this post


Link to post
Share on other sites
  • 0

Hmm,

Forum Tools add in hasn't generated the tables correctly, see attachments:

 

Data in Columns C&D

 

[attachment=1]Combine Sheet.jpg[/attachment]

 

Data (Column Headings) starts in A1

 

[attachment=0]Extract.jpg[/attachment]

Share this post


Link to post
Share on other sites
  • 0

Hello Geeperz,

 

Thanks for your query, and letting me know about the Forum Add-in tool. I'll troubleshoot that this evening!

 

With regard to your query, I've written the code below which should hopefully account for:

1. Instances where the 'Make' Data is missing

2. Instances where there is no 'Location' Data

 

I have used the .Find method which should make it run relatively quickly on a large dataset. Let me know how you get on with it :)

 

Sub TransposeData2()
Application.ScreenUpdating = False
Dim rFound As Range
Dim FirstAddress As String
Dim lC As Long 'Count variable for the rows
lC = 0
Worksheets(Combine Sheet).Activate
With Worksheets(Combine Sheet).Columns(CC)
   Set rFound = .Find(What=Make, After=Range(C & Rows.Count), LookIn=xlValues, _
       lookat=xlWhole, Searchorder=xlByRows, Searchdirection=xlNext, MatchCase=False)
   If Not rFound Is Nothing Then 'Value has been found
       FirstAddress = rFound.Address
       lC = Worksheets(Extract).Range(A & Rows.Count).End(xlUp).Row
       Do
           rFound.Select
           'Add post processing
           If rFound.Offset(0, 1) = vbNullString Then
               'There is some data missing
               Range(rFound.Offset(1, 1), rFound.Offset(1, 1).End(xlDown)).Copy
               Worksheets(Extract).Range(A & lC).Offset(1, 1).PasteSpecial Paste=xlValues, Transpose=True
               lC = lC + 1
           Else
               Range(rFound.Offset(0, 1), rFound.Offset(0, 1).End(xlDown)).Copy
               Worksheets(Extract).Range(A & lC).Offset(1, 0).PasteSpecial Paste=xlValues, Transpose=True
               lC = lC + 1
           End If

           Set rFound = .FindNext(After=rFound)
       Loop While rFound.Address  FirstAddress
   Else 'Value has NOT been found
       Exit Sub
   End If
End With
Application.CutCopyMode = False
Application.ScreenUpdating = False
End Sub

 

I could modify this further to merge the Location field if there is more than 1 line. Let me know if this is something of use to you and I can get it coded ;)

 

Many Thanks

 

Caleeco

Share this post


Link to post
Share on other sites
  • 0

Hi Caleeco,

thanks for your efforts, just like you I need to get on with some real work! Will try & test later but may not have the time.

 

Regards,

GeeperZ

Share this post


Link to post
Share on other sites
  • 0

Hmm, having some issues which I have attempted to solve (mainly missing "" & ':')

so the code now looks like this but only returns the first result, repeatedly if I F5 through the Macro:

 

 

Sub Transpose()
Application.ScreenUpdating = False

Dim rFound As Range
Dim FirstAddress As String
Dim lC As Long 'Count variable for the rows
lC = 0

Worksheets("Combine Sheet").Activate
With Worksheets("Combine Sheet").Columns(3)
    Set rFound = .Find(What:="Make", After:=Range("C" & Rows.Count), LookIn:=xlValues, _
        LookAt:=xlWhole, SearchOrder:=xlByRows, Searchdirection:=xlNext, MatchCase:=False)
    
    If Not rFound Is Nothing Then 'Value has been found
        FirstAddress = rFound.Address
        lC = Worksheets("Extract").Range("A" & Rows.Count).End(xlUp).Row
        Do
            rFound.Select
            'Add post processing
            If rFound.Offset(0, 1) = vbNullString Then
                'There is some data missing
                Range(rFound.Offset(1, 1), rFound.Offset(1, 1).End(xlDown)).Copy
                Worksheets(Extract).Range(A & lC).Offset(1, 1).PasteSpecial Paste:=xlValues, Transpose:=True
                lC = lC + 1
            Else
                Range(rFound.Offset(0, 1), rFound.Offset(0, 1).End(xlDown)).Copy
                Worksheets("Extract").Range("A" & lC).Offset(1, 0).PasteSpecial Paste:=xlValues, Transpose:=True
                lC = lC + 1
            End If
        
            Set rFound = .FindNext(After:=rFound)
        Loop While rFound.Address = FirstAddress
    Else 'Value has NOT been found
        Exit Sub
    End If

Share this post


Link to post
Share on other sites
  • 0

Absolutely spot on, tested with the RDB Merge add in (credit: http://www.rondebruin.nl/merge.htm) on a folder containing over 3000 files, this generated almost 170,000 rows of data. The above macro ran in about 1 minute 40 seconds, the whole process took less than 5 minutes. I ended up with 110 rows of meaningful data. Amazing.

Share this post


Link to post
Share on other sites
  • 0

Hey Caleeco, I'm being driven to resurrect this again. The project never got finished the first time around but as things have developed this has once again become of interest. Since I was last working on this I've had a new computer and I don't appear to have a working copy of the module. Any chance you could help?

I've tried running the code as it appears on your forum but it does not work as expected, it gets to selecting the first instance and then Excel asks where I would like to paste the data. If I step into the macro and F5 it just returns the first result over again. I've looked on MrExcel too but no luck 😞

Share this post


Link to post
Share on other sites
  • 0

Hey GeeperZ

 

Post #2 should be the last 'working' code we made. Has the sheet structure changed at all?

 

Are you able to email me the sheet you're working on so I can do some code testing? 

 

Thanks

Caleeco

Share this post


Link to post
Share on other sites
  • 0

Hey Caleeco, thanks for getting back to me. I'll email the file through. I'll have to strip out some info first but other than that it will be the same as what I'm working on.

Share this post


Link to post
Share on other sites
  • 0

Hi GeeperZ 

 

Thanks for sending over the file. I seem to have a website bug where the NOT (<>) symbol doesnt appear correctly in code samples. 

 

If you look at your TransposeData2 sub-routine, you'll see this line of code:

Loop While rFound.Address = FirstAddress

 

Change it to this:

Loop While rFound.Address <> FirstAddress

 

Tested on my end, seems to work. 

 

Let me know how you get on.

Thanks

Caleeco

Share this post


Link to post
Share on other sites
  • 0

Ah so simple! Thanks for your assistance. Now all I have to do is make the rest of the suite work and we'll be flying!

 

Again, many thanks.

  • Like 1

Share this post


Link to post
Share on other sites

Create an account or sign in to comment

You need to be a member in order to leave a comment

Create an account

Sign up for a new account in our community. It's easy!

Register a new account

Sign in

Already have an account? Sign in here.

Sign In Now

×