为什么这段代码会从第一行开始取

milerzhang

Sub a()

  Dim ExcelID As Excel.Application
  Set ExcelID = New Excel.Application
  Dim oOutlookApp As New Outlook.Application
  Dim oItemMail As Outlook.MailItem
  Set oItemMail = oOutlookApp.CreateItem(olMailItem)
  Dim E, col As Integer
  Dim RanA, RanB As Range
  Dim ARR(), filename, fileroute, email As String
  Dim ICol
  'Call sckg  '删除所有单元格中数据的前后空格
    Worksheets(Array("sheet1")).Select
  ICol = Application.InputBox("请输入你所要分的列：" & Chr(10) & "（如按B列分请输入2）", "提示：", "4", Type:=1)
  Application.CommandBars("Stop Recording").Visible = False
  col = ActiveSheet.UsedRange.Columns.Count
  For Each RanB In Sheet1.Range(Cells(2, ICol), Cells(Sheet1.Range("d65536").End(xlUp).Row, ICol))
    If InStr(X, Sheet1.Cells(RanB.Row, ICol)) = 0 Then
      If X = "" Then
        X = RanB
      Else
        X = X & "," & RanB
      End If
      E = Application.CountIf(Sheet1.Columns(ICol), RanB)
      ReDim ARR(1 To E + 1, 1 To col)
      Set RanA = Sheet1.Cells(1, ICol)
      For Y = 1 To E
        Set RanA = Sheet1.Columns(ICol).Find(RanB, RanA, , , xlByColumns, , , False)
        For P = 1 To col
          If Y = 1 Then
            ARR(Y, P) = Sheet1.Cells(1, P)
            ARR(Y + 1, P) = Sheet1.Cells(RanA.Row, P)
          Else
            ARR(Y + 1, P) = Sheet1.Cells(RanA.Row, P)
          End If
        Next P
      Next Y
      'MsgBox CStr(E)
      'Sheets.Add.Name = RanB '新建工作表，重命名
      filename = CStr(RanB) + ".xls"
      fileroute = "C:\" + CStr(RanB) + ".xls"
      Workbooks.Add
      ActiveWorkbook.SaveAs filename:="C:\" + CStr(RanB) + ".xls", FileFormat:= _
        xlExcel8, ReadOnlyRecommended:=False _
        , CreateBackup:=False
      Sheets("Sheet1").Select
      Cells.Select
      Selection.NumberFormatLocal = "@"
      Selection.Locked = False
      Selection.FormulaHidden = False
      With ActiveSheet
        .Range("A3").Resize(Y, col) = ARR '粘贴数据
        .Rows("2:2").RowHeight = 6 '2行缩少高度
        .Range("A3:Q" & E + 3).Borders.LineStyle = 1 '全部加网格线
        .Range("A1") = Sheet1.Cells(1, ICol) & RanB & "支行" '表头名
        .Range("A1:Q1").Select '全选A1:K1
      With Selection
        .MergeCells = True '合并A1:K1
        .HorizontalAlignment = xlCenter '居中A1:K1
        .Font.Size = 22 '字体设为22号
      End With
      End With
    End If
  Next
      End Sub

milerzhang

是不是excel表格自身有问题？

milerzhang

????????????