Vba实现多个excel汇总为一个excel

过录程序
Sub test()


  Dim r, i, s, k As Integer, lj, str As String, arr
    Sheet1.Range("3:65536").Delete
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    r = 2
    str = ThisWorkbook.Path & "\堂食问卷\"                  '堂食问卷文件夹的第一个文件名
    lj = Dir(str & "*.xls")
    Do While lj <> ""                                       '只要lj不为空，即只要文件存在
        Workbooks.Open str & lj                             '打开堂食问卷中的lj文件
        r = r + 1
        With ActiveWorkbook.Sheets("问卷")       '以下的.cells默认指的是Sheets("问卷")
        
         ActiveWorkbook.Sheets("问卷").Unprotect ""
            .Cells.Replace " ", "", xlPart                  'Sheet(1)的剔空
    
    
            
            
            '基础信息部分
            
            Sheet1.Cells(r, 2) = .Cells(1, 5)
            Sheet1.Cells(r, 3) = .Cells(2, 5)
            If .Cells(4, 5).Font.ColorIndex = 3 Then Sheet1.Cells(r, 4) = "早晨"
            If .Cells(5, 5).Font.ColorIndex = 3 Then Sheet1.Cells(r, 4) = "午餐时段"
            If .Cells(6, 5).Font.ColorIndex = 3 Then Sheet1.Cells(r, 4) = "下午"
            If .Cells(7, 5).Font.ColorIndex = 3 Then Sheet1.Cells(r, 4) = "晚餐时段"
            If .Cells(8, 5).Font.ColorIndex = 3 Then Sheet1.Cells(r, 4) = "晚上"
            
            If .Cells(10, 5).Font.ColorIndex = 3 Then Sheet1.Cells(r, 5) = "繁忙"
            If .Cells(11, 5).Font.ColorIndex = 3 Then Sheet1.Cells(r, 5) = "适中"
            If .Cells(12, 5).Font.ColorIndex = 3 Then Sheet1.Cells(r, 5) = "稀少"
            
            Sheet1.Cells(r, 6) = Mid(.Cells(13, 4), 6, Len(.Cells(13, 4)) - 5)
            
            Sheet1.Cells(r, 7) = .Cells(1, 18)
            Sheet1.Cells(r, 8) = .Cells(2, 18)
            Sheet1.Cells(r, 9) = .Cells(1, 19)
            Sheet1.Cells(r, 10) = .Cells(4, 18)
            Sheet1.Cells(r, 11) = .Cells(6, 18)
            Sheet1.Cells(r, 12) = .Cells(9, 18)
            Sheet1.Cells(r, 13) = .Cells(10, 18)
            Sheet1.Cells(r, 14) = .Cells(12, 18)
            Sheet1.Cells(r, 15) = .Cells(13, 18)
            Sheet1.Cells(r, 16) = Round(.Cells(10, 12), 0)                           '所得分数
            
            
            '到达所检测店面 部分
            
            
            k = 15                                  '问卷中的行数
            s = 17                                  'Sheet1中的列数
            For i = 1 To 4
              If .Cells(k + i, 20) = "×" Then
                 Sheet1.Cells(r, s + i) = 0
              ElseIf .Cells(k + i, 21) = "√" Then
                 Sheet1.Cells(r, s + i) = "NA"
              Else
                 Sheet1.Cells(r, s + i) = 1
              End If
            Next
            
            
            
            k = 20
            s = 22
            For i = 1 To 3
              If .Cells(k + i, 3) = "√" Then
                 Sheet1.Cells(r, s + i) = 1
              Else
                 Sheet1.Cells(r, s + i) = 0
              End If
            Next
            
            
            
            
             '进入所检测店部分
            
            
            k = 25
            s = 26
            For i = 1 To 2
              If .Cells(k + i, 20) = "×" Then
                 Sheet1.Cells(r, s + i) = 0
              ElseIf .Cells(k + i, 21) = "√" Then
                 Sheet1.Cells(r, s + i) = "NA"
              Else
                 Sheet1.Cells(r, s + i) = 1
              End If
            Next
            
            
            
            k = 28
            s = 29
            For i = 1 To 9
              If .Cells(k + i, 3) = "√" Then
                 Sheet1.Cells(r, s + i) = 1
              Else
                 Sheet1.Cells(r, s + i) = 0
              End If
            Next
            
            
            
            
            
             '就座  部分
            
            k = 39
            s = 39
            For i = 1 To 2
              If .Cells(k + i, 20) = "×" Then
                 Sheet1.Cells(r, s + i) = 0
              ElseIf .Cells(k + i, 21) = "√" Then
                 Sheet1.Cells(r, s + i) = "NA"
              Else
                 Sheet1.Cells(r, s + i) = 1
              End If
            Next
            
            
            
            k = 42
            s = 42
            For i = 1 To 5
              If .Cells(k + i, 3) = "√" Then
                 Sheet1.Cells(r, s + i) = 1
              Else
                 Sheet1.Cells(r, s + i) = 0
              End If
            Next
            
            
            
            
             '点餐和下订单  部分
            
            k = 49
            s = 48
            For i = 1 To 5
              If .Cells(k + i, 20) = "×" Then
                 Sheet1.Cells(r, s + i) = 0
              ElseIf .Cells(k + i, 21) = "√" Then
                 Sheet1.Cells(r, s + i) = "NA"
              Else
                 Sheet1.Cells(r, s + i) = 1
              End If
            Next
            
            
            
            k = 55
            s = 54
            For i = 1 To 7
              If .Cells(k + i, 3) = "√" Then
                 Sheet1.Cells(r, s + i) = 1
              Else
                 Sheet1.Cells(r, s + i) = 0
              End If
            Next
            
            
            
              
             '等待用餐/被服务   部分
            
            k = 64
            s = 62
            For i = 1 To 3
              If .Cells(k + i, 20) = "×" Then
                 Sheet1.Cells(r, s + i) = 0
              ElseIf .Cells(k + i, 21) = "√" Then
                 Sheet1.Cells(r, s + i) = "NA"
              Else
                 Sheet1.Cells(r, s + i) = 1
              End If
            Next
            
            
            
            k = 68
            s = 66
            For i = 1 To 6
              If .Cells(k + i, 3) = "√" Then
                 Sheet1.Cells(r, s + i) = 1
              Else
                 Sheet1.Cells(r, s + i) = 0
              End If
            Next
            
            
            
               
             '开始享用食品   部分
            
            k = 75
            s = 73
            For i = 1 To 3
              If .Cells(k + i, 20) = "×" Then
                 Sheet1.Cells(r, s + i) = 0
              ElseIf .Cells(k + i, 21) = "√" Then
                 Sheet1.Cells(r, s + i) = "NA"
              Else
                 Sheet1.Cells(r, s + i) = 1
              End If
            Next
            
            
            
            k = 79
            s = 77
            For i = 1 To 4
              If .Cells(k + i, 3) = "√" Then
                 Sheet1.Cells(r, s + i) = 1
              Else
                 Sheet1.Cells(r, s + i) = 0
              End If
            Next
            
            
            
                 
             '顾客满意度和其它商品   部分
            
            k = 84
            s = 82
            For i = 1 To 2
              If .Cells(k + i, 20) = "×" Then
                 Sheet1.Cells(r, s + i) = 0
              ElseIf .Cells(k + i, 21) = "√" Then
                 Sheet1.Cells(r, s + i) = "NA"
              Else
                 Sheet1.Cells(r, s + i) = 1
              End If
            Next
            
            
            
            k = 87
            s = 85
            For i = 1 To 6
             If .Cells(k + i, 3) = "√" Then
                 Sheet1.Cells(r, s + i) = 1
              Else
                 Sheet1.Cells(r, s + i) = 0
              End If
            Next
            
            
            
            
                  
             '问题解决    部分
            
            k = 94
            s = 92
            For i = 1 To 2
              If .Cells(k + i, 20) = "×" Then
                 Sheet1.Cells(r, s + i) = 0
              ElseIf .Cells(k + i, 21) = "√" Then
                 Sheet1.Cells(r, s + i) = "NA"
              Else
                 Sheet1.Cells(r, s + i) = 1
              End If
            Next
            
            
            
            
               '收到账单，然后离开店面    部分
            
            k = 99
            s = 95
            For i = 1 To 6
              If .Cells(k + i, 20) = "×" Then
                 Sheet1.Cells(r, s + i) = 0
              ElseIf .Cells(k + i, 21) = "√" Then
                 Sheet1.Cells(r, s + i) = "NA"
              Else
                 Sheet1.Cells(r, s + i) = 1
              End If
            Next
            
            
            
            k = 106
            s = 102
            For i = 1 To 5
              If .Cells(k + i, 3) = "√" Then
                 Sheet1.Cells(r, s + i) = 1
              Else
                 Sheet1.Cells(r, s + i) = 0
              End If
            Next
            
            
            
              Sheet1.Cells(r, 110) = .Cells(115, 10)                           '卓越服务
              Sheet1.Cells(r, 111) = .Cells(116, 10)
              Sheet1.Cells(r, 112) = .Cells(117, 10)
              Sheet1.Cells(r, 113) = .Cells(119, 2)                            '注释部分
            
            
            
            arr = [{16,17,18,19,26,27,40,41,50,51,52,53,54,65,66,67,76,77,78,85,86,100,101,102,103,104,105}]
            s = 113
            For i = 1 To 27
                Sheet1.Cells(r, s + i) = .Cells(arr(i), 18)                '期望服务情况说明
            Next
        End With
            Sheet1.Cells(r, 141) = ActiveWorkbook.Name
            ActiveWorkbook.Close False
            lj = Dir
      Loop
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    r1 = r
    MsgBox "运行完毕！" & vbCrLf & "共计：" & r - 2 & "份问卷", vbOKOnly, "温馨提示"
End Sub