The below macros are ALL your code condensed (untested, but could you test it for me?), now all I need is the answer to the 'Next question' of my last message.
These will probably be garbled by Yahoo's line-wrapping:
Sub fromCoverSheet()
Forward Sheets("HAW"), Array("B8", "B5", "B24", "B13", "B35", "B29")
Forward Sheets("KNT"), Array("B5", "B7")
Forward Sheets("SKT"), Array("B6", "B8")
Forward Sheets("NWM"), Array("B6", "B8")
Forward Sheets("WEM"), Array("B9", "B5", "B17", "B14", "B28", "B22")
Forward Sheets("SPK"), Array("B8", "B5", "B16", "B13")
Forward Sheets("HAR"), Array("B7", "B6")
Forward Sheets("KGN"), Array("B8", "B6", "B15", "B13")
Forward Sheets("QPK"), Array("B9", "B5", "B18", "B14", "B28", "B23")
End Sub
Sub Group_Roster_Reverse2()
Reverse Sheets("HAW"), Array("B5", "B9", "B13", "B25", "B29", "B36")
Reverse Sheets("KNT"), Array("B6", "B5")
Reverse Sheets("SKT"), Array("B7", "B6")
Reverse Sheets("NWM"), Array("B7", "B6")
Reverse Sheets("WEM"), Array("B5", "B10", "B14", "B18", "B22", "B29")
Reverse Sheets("SPK"), Array("B5", "B9", "B13", "B17")
Reverse Sheets("HAR"), Array("B6", "B8")
Reverse Sheets("KGN"), Array("B6", "B9", "B13", "B16")
Reverse Sheets("QPK"), Array("B5", "B10", "B14", "B19", "B23", "B29")
End Sub
Sub Forward(TheSheet, PairedCellsArray)
Debug.Assert Application.IsOdd(UBound(PairedCellsArray) - LBound(PairedCellsArray))
With TheSheet
.Range("C1").Value = .Range("D1").Value
For i = LBound(PairedCellsArray) To UBound(PairedCellsArray) Step 2
Debug.Print PairedCellsArray(i), PairedCellsArray(i + 1)
Range(PairedCellsArray(i)).Cut: Range(PairedCellsArray(i + 1)).Insert Shift:=xlDown
Next i
End With
End Sub
Sub Reverse(TheSheet, PairedCellsArray)
Debug.Assert Application.IsOdd(UBound(PairedCellsArray) - LBound(PairedCellsArray))
With TheSheet
.Range("C1").Value = .Range("E1").Value
For i = LBound(PairedCellsArray) To UBound(PairedCellsArray) Step 2
Debug.Print PairedCellsArray(i), PairedCellsArray(i + 1)
Range(PairedCellsArray(i)).Cut: Range(PairedCellsArray(i + 1)).Insert Shift:=xlDown
Next i
End With
End Sub
--- In ExcelVBA@yahoogroups.com, "Pascal" <pascaldaulton@...> wrote:
>
> Yes, there's quite a lot of repeating code, so first I want to condense your code a bit, by having one macro do the repeating stuff and passing to it which cells have to be moved/copied around.
> I notice that all the Forward macros have the same start copying D1 to C1, also all the reverse macros copy E1 to C1. Then the rest is sheet specific. So I summarised each macro, the first pair of cells copy, subsequent pairs cut and insert. You might confirm that I've got it right:
> Sub HAW_Forward_Macro("C1","D1","B8","B5","B24","B13","B35","B29")
> Sub KNT_Forward_Macro("C1","D1","B5","B7")
> Sub SKT_Forward_Macro("C1","D1","B6","B8")
> Sub NMW_Forward_Macro("C1","D1","B6","B8")
> Sub WEM_Forward_Macro("C1","D1","B9","B5","B17","B14","B28","B22")
> Sub SPK_Forward_Macro("C1","D1","B8","B5","B16","B13")
> Sub HAR_Forward_Macro("C1","D1","B7","B6")
> Sub KGN_Forward_Macro("C1","D1","B8","B6","B15","B13")
> Sub QPK_Forward_Macro("C1","D1","B9","B5","B18","B14","B28","B23")
> Sub HAW_Reverse_Macro("C1","E1","B5","B9","B13","B25","B29","B36")
> Sub KNT_Reverse_Macro("C1","E1","B6","B5")
> Sub SKT_Reverse_Macro("C1","E1","B7","B6")
> Sub NWM_Reverse_Macro("C1","E1","B7","B6")
> Sub WEM_Reverse_Macro("C1","E1","B5","B10","B14","B18","B22","B29")
> Sub QPK_Reverse_Macro("C1","E1","B5","B10","B14","B19","B23","B29")
> Sub SPK_Reverse_Macro("C1","E1","B5","B9","B13","B17")
> Sub HAR_Reverse_Macro("C1","E1","B6","B8")
> Sub KGN_Reverse_Macro("C1","E1","B6","B9","B13","B16")
>
> Next question: You mention repeating until C1 reaches a certain date, and I also presume that the the cell C1 on all the sheets contain the same date - that is they never get out of kilter? If they were to get out of kilter, would you like the macro to bring them all back into line?
>
> I don't think this should be too difficult to do.
>
> --- In ExcelVBA@yahoogroups.com, Tony Davis <studiot@> wrote:
> >
> > Hi all,
> >
> > I just wondered if there was any luck with the following, as I never had any
> > posts back.
> >
> > kind regards
> >
> > Tony
Be sure to check out TechTrax Ezine for many, free Excel VBA articles! Go here: http://www.mousetrax.com/techtrax to enter the ezine, then search the ARCHIVES for EXCEL VBA.
----------------------------------
Visit our ExcelVBA group home page for more info and support files:
http://groups.yahoo.com/group/ExcelVBA
----------------------------------
More free tutorials and resources available at:
http://www.mousetrax.com
----------------------------------
Tidak ada komentar:
Posting Komentar