如果單元格值不相等，則VBA / EXCEL在特定行上拆分excel文件

Question

我對分割的excel文件沒什么問題。 我的情況是我有一個文件，例如有10k行，我想每1k行拆分一次，但是最重要的是第二條語句，它應該說如果我們在1k行上並且b行中的單元格的值等於前一個單元格，那么當它們不相等時，我們應該拆分文件。

現在，我可以拆分excel文件並保存，但是我不知道如何編寫if語句是否擁有循環。 我的if語句：

 If counter = 1500 And require.Value <> require.Offset(-1).Value Then

還有一點，文件中的MAX行必須為1500，且不包含標題

這是我的代碼：

Sub SplitRowsToFiles()

Dim wb As Workbook
Dim saveFile As String
Dim WorkRng As Range
Dim WR As Range
Dim last As Double
Dim counter As Double
Dim part As Double
Dim name As String

Dim string1 As String
Dim string11 As String
Dim string12 As String
Dim Taba() As String
Dim value1 As Double
Dim header As Range
Dim require As Range


On Error Resume Next

xTitleId = "Export To TXT"

Set require = Range("b140:b14000")

Set WorkRng = Application.Selection
Set WorkRng = Application.InputBox("Range", xTitleId, "A2:C11", Type:=8)
Set header = Application.Selection
Set header = Application.InputBox("Header range", xTitleId, "A1:C1", Type:=8)
Set WR = WorkRng
saveFile = Application.GetSaveAsFilename

With ActiveSheet.UsedRange

    last = .Cells(1, 1).Row + .Rows.Count - 1

  End With
  MsgBox "ab" & last & "ab"

string1 = WorkRng.Address()

Taba() = Split(string1, ":")

string11 = Mid(Taba(0), 4)
string12 = Mid(Taba(1), 4)

value1 = Val(string12) - Val(string11) + 1


For counter = 0 To last
If counter = 1500 And require.Value <> require.Offset(-1).Value Then

part = part + 1
Application.ScreenUpdating = True
Application.DisplayAlerts = False
Set wb = Application.Workbooks.Add
Set WR = Union(header, WR)
WR.Copy
wb.Worksheets(1).Paste
name = saveFile & part & ".xls"
wb.SaveAs Filename:=name, FileFormat:=xlExcel8, CreateBackup:=False
wb.Close
Application.CutCopyMode = False
Application.DisplayAlerts = True
Application.ScreenUpdating = False
Set WorkRng = WorkRng.Offset(value1)
Set WR = WorkRng
counter = counter + value1
Else
End If
Next


End Sub

謝謝！

Answer 1

以下將原始文件拆分為多個“拆分”文件，以使每個“拆分”文件將至少具有“ blkSize”行，包括標題（目前，根據您的問題陳述，“ blkSize”設置為1000）並且不超過'blkSize'+'maxLimit'行（目前將maxlimit設置為500）-因此包括標頭在內的行不超過1500。

我假設原始文件中的前“ hdrSize”行是要復制到每個文件的標頭，作為前幾行（“ hdrSize”當前為1）。

如果在“ B”列中沒有重復項，那么您將獲得“ blkSize”行的“拆分”文件，但最后一個將僅包含剩余的行。 如果在拆分發生時“ B”列中有重復項，您將獲得從“ blkSize”到“ blkSize” +“ maxLimit”行的可變大小文件大小。 由於每個拆分文件的長度可能會有所不同，具體取決於“ B”列中重復項的數量，因此在運行代碼之前您不會知道將生成多少個文件。

您可以根據需要在代碼頂部設置以下每個變量：“ hdrSize”，“ blkSize”和“ maxLimit”。

Option Explicit


Sub SplitRowsToFiles()

  Dim hdrSize As Integer: hdrSize = 1
  Dim blkSize As Integer:  blkSize = 1000 - hdrSize
  Dim maxLimit As Integer: maxLimit = 500

  Dim wb As Workbook
  Dim wrkSht As Worksheet
  Dim saveFile As String, name As String
  Dim WR As Range, header As Range

  Set wrkSht = ActiveSheet
  Set header = wrkSht.Rows("1:" & hdrSize)

  saveFile = Application.GetSaveAsFilename

  Dim last As Integer
  With wrkSht.UsedRange
    last = .Rows.Count
  End With

  Dim i As Integer, j As Integer
  Dim limit As Integer, part As Integer
  part = 0
  i = hdrSize + 1 ' skip the header

  Do While True

    j = i + blkSize - 1
    If j <= last Then
      ' process from blkSize to blkSize+maxLimit rows
      limit = j + maxLimit
      Do While Cells(j, "B") = Cells(j + 1, "B") And _
           j < limit And j < last
        j = j + 1
      Loop
    Else
      ' otherwise process up to the last row
      j = last
    End If

    Application.ScreenUpdating = True
    Application.DisplayAlerts = False

     Set wb = Application.Workbooks.Add 
     Set WR = wrkSht.Rows(i & ":" & j)

     header.Copy wb.Worksheets(1).Rows("1:" & hdrSize)
     WR.Copy wb.Worksheets(1).Rows(hdrSize + 1)

     part = part + 1
     name = saveFile & part & ".xls"
     wb.SaveAs Filename:=name, FileFormat:=xlExcel8, CreateBackup:=False
     wb.Close

    Application.DisplayAlerts = True
    Application.ScreenUpdating = False

    i = j + 1
    If i > last Then Exit Do

  Loop

End Sub

Answer 2

我尚未對此進行測試，但是我認為您只是缺少一個達到極限（1500）並重置為零（受B列不匹配）的計數器。 我用過pcounter （p代表'partial'）

嘗試這個：

Sub SplitRowsToFiles()

Dim wb As Workbook
Dim saveFile As String
Dim WorkRng As Range
Dim WR As Range
Dim last As Double
Dim counter As Double
Dim pcounter As Double
Dim part As Double
Dim name As String

Dim string1 As String
Dim string11 As String
Dim string12 As String
Dim Taba() As String
Dim value1 As Double
Dim header As Range
Dim require As Range


On Error Resume Next

xTitleId = "Export To TXT"

Set require = Range("b140:b14000")

Set WorkRng = Application.Selection
Set WorkRng = Application.InputBox("Range", xTitleId, "A2:C11", Type:=8)
Set header = Application.Selection
Set header = Application.InputBox("Header range", xTitleId, "A1:C1", Type:=8)
Set WR = WorkRng
saveFile = Application.GetSaveAsFilename

With ActiveSheet.UsedRange
    last = .Cells(1, 1).Row + .Rows.Count - 1
End With

MsgBox "ab" & last & "ab"

string1 = WorkRng.Address()

Taba() = Split(string1, ":")

string11 = Mid(Taba(0), 4)
string12 = Mid(Taba(1), 4)

value1 = Val(string12) - Val(string11) + 1

pcounter = 0

For counter = 0 To last
    If pcounter > 1500 And require.Value <> require.Offset(-1).Value Then
        pcounter = 0
        part = part + 1
        Application.ScreenUpdating = True
        Application.DisplayAlerts = False
        Set wb = Application.Workbooks.Add
        Set WR = Union(header, WR)
        WR.Copy
        wb.Worksheets(1).Paste
        name = saveFile & part & ".xls"
        wb.SaveAs Filename:=name, FileFormat:=xlExcel8, CreateBackup:=False
        wb.Close
        Application.CutCopyMode = False
        Application.DisplayAlerts = True
        Application.ScreenUpdating = False
        Set WorkRng = WorkRng.Offset(value1)
        Set WR = WorkRng
        counter = counter + value1
    Else
        pcounter = pcounter + 1
    End If
Next
Application.ScreenUpdating = True
Application.DisplayAlerts = False    

End Sub