how to dim nextrow statement to this code??

[sezuh]

Hi,
I have this code by Myrna Larson and I have more than 100 data with similar result,so I need all the result in one column. But somehow I could not find a way to “Dim nextrow” statement .would someone kindly help me on this please? I tried for 3 hours last night with no success. First I changed this (Worksheets.Add) to ““worksheet (“sheet6”)”” but could not
Find solution for this statement;

NextRow = Sheets("Sheet6").Range("A" & rows.count).End(xlUp).Row + 1

here is the code;

Option Explicit 
Dim vAllItems As Variant
Dim Buffer() As String
Dim BufferPtr As Long
Dim Results As Worksheet
'
' Myrna Larson, July 25, 2000, Microsoft.Public.Excel.Misc
 
Sub ListPermutationsOrCombinations()
Dim Rng As Range
Dim PopSize As Integer
Dim SetSize As Integer
Dim Which As String
Dim n As Double
Const BufferSize As Long = 4096
 
Worksheets("Sheet1").Range("A1").Select
Set Rng = Selection.Columns(1).Cells
If Rng.Cells.Count = 1 Then
Set Rng = Range(Rng, Rng.End(xlDown))
End If
 
PopSize = Rng.Cells.Count - 2
If PopSize < 2 Then GoTo DataError
 
SetSize = Rng.Cells(2).Value
If SetSize > PopSize Then GoTo DataError
 
Which = UCase$(Rng.Cells(1).Value)
Select Case Which
Case "C"
n = Application.WorksheetFunction.Combin(PopSize, SetSize)
Case "P"
n = Application.WorksheetFunction.Permut(PopSize, SetSize)
Case Else
GoTo DataError
End Select
'If n > Cells.CountLarge Then GoTo DataError
 
Application.ScreenUpdating = False
 
Set Results = Worksheets.Add
 
vAllItems = Rng.Offset(2, 0).Resize(PopSize).Value
ReDim Buffer(1 To BufferSize) As String
BufferPtr = 0
 
If Which = "C" Then
AddCombination PopSize, SetSize
Else
AddPermutation PopSize, SetSize
End If
vAllItems = 0
 
Application.ScreenUpdating = True
Exit Sub
 
DataError:
If n = 0 Then
Which = "Enter your data in a vertical range of at least 4 cells." _
& String$(2, 10) _
& "Top cell must contain the letter C or P, 2nd cell is the Number" _
& "of items in a subset, the cells below are the values from Which" _
& "the subset is to be chosen."
 
Else
Which = "This requires " & Format$(n, "#,##0") & _
" cells, more than are available on the worksheet!"
End If
MsgBox Which, vbOKOnly, "DATA ERROR"
Exit Sub
End Sub
 
Private Sub AddPermutation(Optional PopSize As Integer = 0, _
Optional SetSize As Integer = 0, _
Optional NextMember As Integer = 0)
 
Static iPopSize As Integer
Static iSetSize As Integer
Static SetMembers() As Integer
Static Used() As Integer
Dim i As Integer
 
If PopSize <> 0 Then
iPopSize = PopSize
iSetSize = SetSize
ReDim SetMembers(1 To iSetSize) As Integer
ReDim Used(1 To iPopSize) As Integer
NextMember = 1
End If
 
For i = 1 To iPopSize
If Used(i) = 0 Then
SetMembers(NextMember) = i
If NextMember <> iSetSize Then
Used(i) = True
AddPermutation , , NextMember + 1
Used(i) = False
Else
SavePermutation SetMembers()
End If
End If
Next i
 
If NextMember = 1 Then
SavePermutation SetMembers(), True
Erase SetMembers
Erase Used
End If
 
End Sub 'AddPermutation
 
Private Sub AddCombination(Optional PopSize As Integer = 0, _
Optional SetSize As Integer = 0, _
Optional NextMember As Integer = 0, _
Optional NextItem As Integer = 0)
 
Static iPopSize As Integer
Static iSetSize As Integer
Static SetMembers() As Integer
Dim i As Integer
 
If PopSize <> 0 Then
iPopSize = PopSize
iSetSize = SetSize
ReDim SetMembers(1 To iSetSize) As Integer
NextMember = 1
NextItem = 1
End If
 
For i = NextItem To iPopSize
SetMembers(NextMember) = i
If NextMember <> iSetSize Then
AddCombination , , NextMember + 1, i + 1
Else
SavePermutation SetMembers()
End If
Next i
 
If NextMember = 1 Then
SavePermutation SetMembers(), True
Erase SetMembers
End If
 
End Sub 'AddCombination
 
Private Sub SavePermutation(ItemsChosen() As Integer, _
Optional FlushBuffer As Boolean = False)
 
Dim i As Integer, sValue As String
Static RowNum As Long, ColNum As Long
 
If RowNum = 0 Then RowNum = 1
If ColNum = 0 Then ColNum = 1
 
If FlushBuffer = True Or BufferPtr = UBound(Buffer()) Then
If BufferPtr > 0 Then
If (RowNum + BufferPtr - 1) > Rows.Count Then
RowNum = 1
ColNum = ColNum + 1
If ColNum > 256 Then Exit Sub
End If
 
Results.Cells(RowNum, ColNum).Resize(BufferPtr, 1).Value _
= Application.WorksheetFunction.Transpose(Buffer())
RowNum = RowNum + BufferPtr
End If
 
BufferPtr = 0
If FlushBuffer = True Then
Erase Buffer
RowNum = 0
ColNum = 0
Exit Sub
Else
ReDim Buffer(1 To UBound(Buffer))
End If
 
End If
 
'construct the next set
For i = 1 To UBound(ItemsChosen)
sValue = sValue & ", " & vAllItems(ItemsChosen(i), 1)
Next i
 
'and save it in the buffer
BufferPtr = BufferPtr + 1
Buffer(BufferPtr) = Mid$(sValue, 3)
End Sub

Any help or suggestion on this would be much appreciated.

 

[sezuh]

hiker,

Sorry that I was not able to solve your request.

That's not a problem at all.I can not thank you enough for your time and effort on this matter.
What i'm going to do is ,leave the code as its to add new sheets then copy all of them to one sheet after that.
but what i would like to ask your opinion, i found this code copying from 3 sheet to sheet6.but i may have more than 60 sheets,is there a way to express this(short version) in the code instead of writing every sheet name?
here is the code;

Sub Copy_Sheets()     
    Dim ws As Worksheet
     
    Application.ScreenUpdating = False
     
    For Each ws In Sheets(Array("sheet3", "sheet4", "sheet5"))
        With ws
            .Range("A1:a15").Copy
            Worksheets("sheet6").Range("A" & Cells(Rows.Count, 1).End(xlUp).Row + 1).PasteSpecial (xlPasteValues)
        End With
    Next ws
     
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
     
End Sub

 

[hiker95]

sezuh,

Do you have a list of the worksheet names that you do not want your latest macro to run on?

 

[sezuh]

Hi,

Do you have a list of the worksheet names that you do not want your latest macro to run on?

Sheet1,sheet2 and sheet3

 

[hiker95]

sezuh,

'***** make sure that all sheet names are spelled CORRECTLY *****


Please TEST this FIRST in a COPY of your workbook (always make a backup copy before trying new code, you never know what you might lose).

Option Explicit
Sub Copy_SheetsV2()
' hiker95, 10/27/2013
' http://www.mrexcel.com/forum/excel-questions/735339-how-dim-nextrow-statement-code-2.html
Dim ws As Worksheet, nr As Long
Application.ScreenUpdating = False
For Each ws In ThisWorkbook.Worksheets

  '***** make sure that all sheet names are spelled CORRECTLY *****
  
  If ws.Name <> "Sheet1" And ws.Name <> "sheet2" And ws.Name <> "sheet3" And ws.Name <> "sheet6" Then
    With ws
      .Range("A1:A15").Copy
      nr = Sheets("sheet6").Range("A" & Rows.Count).End(xlUp).Offset(1).Row
      Sheets("sheet6").Range("A" & nr).PasteSpecial (xlPasteValues)
    End With
  End If
Next ws
Sheets("sheet6").Activate
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub

Before you use the macro with Excel 2007 or newer, save your workbook, Save As, a macro enabled workbook with the file extension .xlsm

Then run the Copy_SheetsV2 macro.