VBA Script Loop Help

Zarfot · Mar 7th 2017

Hello all:

My VBA script is "almost" completed, but needs help correcting some errors before it works.
The script is supposed to loop through filters in Regions!B5 (it's the column header) for data in Regions!B6:B553, then after filtering, copy Regions!A3:R3 to Temp!A1:R1 for each unique filtered value. For example, if there are 10 unique IDs in Regions!B, Temp!A1:R1 should have one row for each value, creating a dataset from A1:R1, to A10:R10.
For whatever reason, the final output generated on RegionsSummary! is not looping through each filter to copy+Paste on the sheet, it is pasting duplicates of the first unique filter value, for as many times as there are unique values in regions!B.
Can anyone identify the error? It's likely having to do with LR3 on RegionSummary, finding the last row. Nothing (according to the code) exists on RegionSummary, so it only applies the pasted value to row LR3+1 in column A. That doesn't change, so the loop keeps overwriting. If Dim LR3 is put outside of the loop, then ReDim inside of the loop, it might work, but I'm not sure how this could be accomplished. Here is the file link: http://s000.tinyupload.com/dow…2773662777787382231444371 I appreciate any help!

Code

Sub Testing()




' Gets Number of Row in Regions Sheet
Sheets("Regions").Activate
LR1 = Cells(Rows.Count, "A").End(xlUp).Row




'Creates a New Worksheet and copy's the data from regions, enters the copied data into the
'New Temp Sheet and then removes the duplicates to create your list of unique items to filter on




'Creating the New WorkSheet
Sheets.Add.Name = "Temp"




'Copy the data
Sheets("Regions").Activate
Range("A6:R" & LR1).Select
Selection.Copy




'Paste the data into Temp Sheet
Sheets("Temp").Activate
Range("A1").Select
ActiveSheet.Paste




'Get Number of Rows pasted
LR2 = Cells(Rows.Count, "A").End(xlUp).Row




'Remove the duplicates
Cells.Select
ActiveSheet.Range("A1:R" & LR2).RemoveDuplicates Columns:=2, Header:=xlNo




'Counts how many items left to check
NumCheckVal = Cells(Rows.Count, "A").End(xlUp).Row




'Loop through each Item to filter on
For e = 1 To NumCheckVal




    'Assigns the Filter value
    CheckVal = Sheets("Temp").Range("B" & e)




    'Navigate to the region sheet
    Sheets("Regions").Activate




    'Filter the sheet
    ActiveSheet.Range("A5:R" & LR1).AutoFilter Field:=2, Criteria1:=CheckVal




    'Copy the data
    Range("A3:R3").Select
    Selection.Copy




    'Navigate to the RegionSummary Sheet and paste the values
    Sheets("RegionSummary").Activate




    'If you dont want this to actually overwrite but rather add to the end of RegionSummary then uncomment the following Line
    ' and replace the range below Range("A12").Select should be changed to Range("A" & LR3 + 1).Select
    'If left as is it will run through and just overwrite A12:R12 as it loops through
    ' Adjusting this will make it so that it steps down a row each time it runs through
    ' First Value on A12:R12 next Vlue on A13:R13 Etc until it runs through all the options




    LR3 = Cells(Rows.Count, "A").End(xlUp).Row




    Range("A" & LR3 + 1).Select
    ActiveSheet.Paste




    'Go back to region sheet and unfilter Column B
    Sheets("Regions").Activate
    ActiveSheet.Range("A5:R" & LR2).AutoFilter Field:=2




'Run next loop
Next e




Application.DisplayAlerts = False
Sheets("Temp").Delete
Application.DisplayAlerts = True




End sub

Display More

**KjBox** · Mar 7th 2017

Re: VBA Script Loop Help

Is this what you are trying to do?

Filter the Table on the Regions sheet for each Highway ID and place the values in row 3 of the the Regions sheet into a Table on the Summary sheet?

Zarfot · Mar 7th 2017

Re: VBA Script Loop Help

Correct!

Smallman · Mar 7th 2017

Re: VBA Script Loop Help

Hi

The problem with your first attempt is the macro pastes the formulas not the values.

I have been working on this in the mean time while you cowboys have been chin wagging. That MakeList Function slows the whole file.

I cleaned up the file to present the way I would have it. Took out the table and came up with the following.

Code

Sub IsolateMove()
Dim sh As Worksheet
Dim ws As Worksheet
Dim i As Integer
Set sh = Sheet2 'Regions sheet
Set ws = Sheet4111 'Region Summary sheet4112???  WTF
Application.ScreenUpdating = False
sh.[B5:B5000].AdvancedFilter 2, [T1], , 1
    For i = 2 To sh.Range("T" & Rows.Count).End(xlUp).Row
        sh.[B5:B5000].AutoFilter 1, sh.Range("T" & i)
        sh.[A3:R3].Copy
        ws.[A65536].End(xlUp)(2).PasteSpecial xlPasteValues
    Next i
    
sh.[t1:t200].Clear
Application.ScreenUpdating = True
End Sub

Display More

Goes nicely.

Take care

Smallman

Zarfot · Mar 7th 2017

Re: VBA Script Loop Help

Hi Smallman,

Forgive me -- I'm on my mac where Excel is quite buggy compared to my windows work laptop where I use Excel frequently.

It seems your output in the summary sheet is the exact data i'm looking for. Fantastic work, thank you very much! I am very very grateful.

I did have one question, and that may be due to my mac being buggy, but I see you used the run button which generated the data. Will I lose the functionality to sort the data through the named ranges to only have certain projects generate the data at once, rather than all be displayed at the same time? I will test in 8 hours when I have my windows computer available. It could just be I lost some functionality on my current computer.

Thank you again!

**KjBox** · Mar 7th 2017

Re: VBA Script Loop Help

Try the attached.

I have made the cells with data in Row 3 of the Regions sheet a named range ("FilterResults"). I added a button to the Summary sheet, click that to summarize all the Projects.

Code assigned to that button is

Code

Sub CreateSummary()
    Dim x, HwIDs, FData, i As Long
    
    Application.ScreenUpdating = 0
    x = [tbldata]
    With CreateObject("system.collections.arraylist")
        For i = 2 To UBound(x, 1)
            If Not .contains(x(i, 2)) Then .Add x(i, 2)
        Next
        .Sort: HwIDs = .toarray
        ReDim y(1 To .Count, 1 To UBound(x, 2))
    End With
    For i = 0 To UBound(HwIDs)
        [tbldata].AutoFilter 2, CStr(HwIDs(i))
        FData = Application.Transpose([FilterResults])
        For ii = 1 To UBound(FData)
            y(i + 1, ii) = FData(ii, 1)
        Next
    Next
    With Sheets("RegionSummary")
        If .[a12] <> "" Then .ListObjects(1).DataBodyRange.Delete
        .[a12].Resize(UBound(y, 1), UBound(y, 2)) = y
        [FilterResults].Copy: [tblSummary].PasteSpecial xlPasteFormats
        With Application
            .CutCopyMode = 0
            .Goto .[a1]
        End With
    End With
    [tbldata].AutoFilter
    ActiveWindow.ScrollColumn = 1
    
End Sub

Display More

Zarfot · Mar 7th 2017

Re: VBA Script Loop Help

You are both flipping fantastic human beings! I was able to test the scripts out this morning. Great work! and Thank you!

Smallman · Mar 7th 2017

Re: VBA Script Loop Help

Not problem Zarfot - Thanks for the kind words.

I am glad you got it sorted.

Take care

Smallman

**KjBox** · Mar 8th 2017

Re: VBA Script Loop Help

You're welcome.

VBA Script Loop Help

Participate now!

Share