VB数据重组问题，麻烦老师帮看下

txd136

源文件


生成的文件是错的


正确生成的表格应该是如下


以下是代码，麻烦老师帮忙看看哪里错了，生成的文件是错的

Sub 生成导入数据()

Dim rng As Range, i As Integer
    arr = Sheet1.Range("a1").CurrentRegion
   
    ReDim brr(1 To UBound(arr), 1 To 11)
    For i = 2 To UBound(arr)
        
            If arr(i, 8) <> 0 Then
                k = k + 1
                For j = 1 To 9
                    brr(k, j) = arr(i, j)
                    
                Next
            
            
               
            End If
      
    Next
    Sheet2.Range("A2:j" & Rows.Count).ClearContents
    Sheet2.Range("A2").Resize(UBound(brr), 10) = brr
   
   
   Sheets("导入数据").Columns("A:A").SpecialCells(xlCellTypeBlanks).EntireRow.Delete '删除空白行
      
    '关闭屏幕刷新
    Application.ScreenUpdating = False
     
    Sheets("导入数据").Activate
    Range("A:H").Select
   
    With Selection.Font
        
        .Name = "微软雅黑"       '设置字体为微软雅黑
         
   Selection.HorizontalAlignment = xlHAlignCenter  '设置左右居中对齐

   Selection.VerticalAlignment = xlVAlignCenter     '设置上下居中对齐

   Range("a1").CurrentRegion.Borders.LineStyle = 1    '设置边框
      
  '以下设置自动换行
     Sheets("导入数据").Select
     Range("A:H").Select
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .WrapText = True
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
     '以上设置自动换行
   
     Sheets("导入数据").Select
     Range("A:H").Select
  Selection.EntireColumn.AutoFit  '设置自动列宽
   End With
   
   
   
    Sheets("导入数据").Select
    Range("K1").Select
   
End Sub

peteryhr

Sheets("导入数据").Columns("A:A").SpecialCells(xlCellTypeBlanks).EntireRow.Delete '删除空白行是不是这里出错了？

zjdh

Sheets("导入数据").Columns("A:A").SpecialCells(xlCellTypeBlanks).EntireRow.Delete '删除空白行
改成
Sheets("导入数据").Columns("H:H").SpecialCells(xlCellTypeBlanks).EntireRow.Delete '删除空白行

即可