VBA / EXCEL如果单元格值不相等，则在特定行上拆分excel文件
我有分裂excel文件的小问题。 我的情况是，我有例如10K行的文件，我想分裂每1K行，但最重要的是第二个说法，应该说，如果我们在1K行，行中的单元格的值等于先前的单元格然后我们应该拆分文件，当他们不相等。
现在我可以拆分excel文件并保存，但我不知道如何写if语句循环，我有。 我的if语句：
If counter = 1500 And require.Value <> require.Offset(-1).Value Then 还有一件事情是文件中的最大行数不能超过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
谢谢！
下面将把原始文件拆分成多个“分割”文件，这样每个“分割”文件将至less包含一个包含头部的行的“blkSize”（根据问题陈述，“blkSize”被设置为1000）并且不超过'blkSize'+'maxLimit'行（maxlimit目前设置为500） – 因此不超过1500行（包括头部）。
我假设您的第一个'hdrSize'行在原始文件中是您想要复制到每个文件的头部作为前几行（'hdrSize'目前是1）。
如果在“B”列中没有重复项，那么除了最后一行将包含剩余行之外，您将得到“blkSize”行的“分割”文件。 如果你在分割点出现了'B'列中的重复项，你会得到一个从'blkSize'到'blkSize'+'maxLimit'行的可变大小的文件大小。 由于每个分割文件可能具有不同的长度，具体取决于“B”列中重复项的数量，所以在运行代码之前，您不会知道将生成多less个文件。
您可以在代码顶部设置这些variables中的每一个：'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
我没有testing过这个，但是我认为你只是错过了一个达到极限（1500）的计数器，并且重置为零（根据列B不匹配）。 我用pcounter （p为'偏'）
尝试这个：
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