Excel VBA: Birden Çok Sayfaya Böl

Question

Kullanıcının makroyu gerçekleştirmek için bir sayfa seçmesine izin veren ve seçili sayfayı birden fazla sayfaya bölmek olan son satırın X satır satırını girmesini sağlayan bir UserForm oluşturuyorum X satır sayısı ile.

Kodu: Ben düzgün nasıl yapılacağını anlamaya gibi olamaz çünkü yardıma ihtiyacım nerede

Dim rowCount As Long 
Dim rowEntered As Long 
Dim doMath As Long 

rowCount = Sheets(Me.ComboBox1.Value).Cells(Rows.Count, "A").End(xlUp).Row 'Count Number of Rows in selected Sheet 
rowEntered = Val(Me.TextBox1.Value) 'User enters X amount 

If rowCount < rowEntered Then 
    MsgBox "Enter in another number" 
Else 
doMath = (rowCount/rowEntered) 
For i = 1 to doMath 
Sheets.Add.name = "New-" & i 
Next i 

'Help!! 
For i= 1 to doMath 
Sheets("New-" & i).Rows("1:" & rowEntered).Value = Sheets(Me.ComboBox1.Value).Rows("1:" & rowEntered).Value 
Next i 
End If 

kodunun son bölümüdür ..

Kod şu anda yeni aracılığıyla döngüler eklenmiş sayfalar ve aynı satırlarda "yapıştır". Örneğin, seçilen sayfa 1000 satır (rowCount) ve satırEntered 500 ise, 2 yeni sayfa oluşturur. 1-500 sıra Yeni-1'e gitmeli ve Satır 501-1000 Yeni-2'ye gitmeli. Bunu nasıl başarabilirim?

Answer 1

aşağıda gösterildiği gibi sorunlu kod parçacığını değiştirin:

For i = 1 To doMath 
    Sheets("New-" & i).Range("1:" & rowEntered).Value = Sheets(Me.ComboBox1.Value).Range((i - 1) * rowEntered + 1 & ":" & i * rowEntered).Value 
Next i 

da "tavan" değerini hesaplamak için aşağıdaki satırı değiştirin:

doMath = Fix(rowCount/rowEntered) + IIf(rowCount Mod rowEntered > 0, 1, 0) 

hesaplamak için kullanılan taklit vba "tavan" fonksiyonu doMath değeri ayrıca şu dillerde de yazılabilir:

doMath = Int(RowCount/rowEntered) + Abs(RowCount Mod rowEntered > 0) 

Not: Bu örnekte, VBA INT ve FIX işlevlerini birbirinin yerine kullanılabilir şekilde kullanabilirsiniz.

Bu yardımcı olacaktır umarım.

Answer 2

Aşağıdaki kodu kontrol edin. Lütfen yorumları okuyun.

Option Explicit 

'this procedure fires up with button click 
Sub Button1_Click() 

    SplitDataToSheets Me.ComboBox1.Value, CInt(Me.TextBox1.Value) 

End Sub 

'this is main procedure 
Sub SplitDataToSheets(ByVal shName As String, ByVal rowAmount As Long) 
Dim srcWsh As Worksheet, dstWsh As Worksheet 
Dim rowCount As Long, sheetsToCreate As Long 
Dim i As Integer, j As Long 

'handle events 
On Error GoTo Err_SplitDataToSheets 

'define source worksheet 
Set srcWsh = ThisWorkbook.Worksheets(shName) 
'Count Number of Rows in selected Sheet 
rowCount = srcWsh.Range("A" & srcWsh.Rows.Count).End(xlUp).Row 
'calculate the number of sheets to create 
sheetsToCreate = CInt(rowCount/rowAmount) + IIf(rowCount Mod rowAmount > 0, 1, 0) 

If rowCount < rowAmount Then 
    If MsgBox("The number of rows in source sheet is less then number of " & vbCr & vbCr & _ 
       "The rest of message", vbQuestion + vbYesNo + vbDefaultButton2, "Question..") = vbYes Then GoTo Exit_SplitDataToSheets 
End If 
' 
j = 0 
'create the number of sheets in a loop 
For i = 1 To sheetsToCreate 
    'check if sheet exists 
    If SheetExists(ThisWorkbook, "New-" & i) Then 
     'clear entire sheet 
     Set dstWsh = ThisWorkbook.Worksheets("New-" & i) 
     dstWsh.Cells.Delete Shift:=xlShiftUp 
    Else 
     'add new sheet 
     ThisWorkbook.Worksheets.Add After:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count) 
     Set dstWsh = ActiveSheet 
     dstWsh.Name = "New-" & i 
    End If 
    'copy data 
    srcWsh.Range("A" & j + 1 & ":A" & j + rowAmount).EntireRow.Copy dstWsh.Range("A1") 
    'increase a "counter" 
    j = j + rowAmount 
Next i 

'exit sub-procedure 
Exit_SplitDataToSheets: 
    On Error Resume Next 
    Set srcWsh = Nothing 
    Set dstWsh = Nothing 
    Exit Sub 

'error sub-procedure 
Err_SplitDataToSheets: 
    MsgBox Err.Description, vbExclamation, Err.Number 
    Resume Exit_SplitDataToSheets 

End Sub 

'function to check if sheet exists 
Function SheetExists(ByVal wbk As Workbook, ByVal wshName As String) As Boolean 
Dim bRetVal As Boolean 
Dim wsh As Worksheet 

On Error Resume Next 
Set wsh = wbk.Worksheets(wshName) 

bRetVal = (Err.Number = 0) 
If bRetVal Then Err.Clear 

SheetExists = bRetVal 

End Function