如何各表插入一列到A列，并且提取A2单元格的店铺简称名到A列

yu88

1.如何在各表里插入一列到A列，并且提取A2单元格的店铺简称名到A列
2.复制各表第4行以下的内容到一张表里，即“提取表效果”表的样子

新建文件夹.rar (15.58 KB, 下载次数: 12)

2014-5-13 09:50 上传

点击文件名下载附件

zhy400137

Sub try()
    Dim file() As String, FileStr As String, n As Integer, PathStr As String, namess As String, ActiveWB As Workbook, cell As Range
    Dim k As Integer, t As Integer
    With Application.FileDialog(msoFileDialogFolderPicker)
    If .Show Then
        PathStr = .SelectedItems(1)
    Else
        Exit Sub
    End If
    End With
    On Error Resume Next
    FileStr = Dir(PathStr & IIf(Right(PathStr, 1) = "\", "", "\") & "*.xls*")
    While Len(FileStr) > 0
        n = n + 1
        ReDim Preserve file(1 To n)
        file(n) = PathStr & IIf(Right(PathStr, 1) = "\", "", "\") & FileStr
        FileStr = Dir()
    Wend
    If n = 0 Then MsgBox "û·￠ÏÖexcelÎļt": Exit Sub
    Set ActiveWB = ActiveWorkbook
    Range("A1") = "μêÆì¼ò3Æ"
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Stop
    For k = 1 To n
        namess = Dir(file(k))
        If namess = ActiveWB.Name Then GoTo lines:
        Workbooks.Open Filename:=file(k)
        t = t + 1
        ActiveWB.Activate
        If t = 1 Then Intersect(Workbooks(namess).Sheets(1).UsedRange, Workbooks(namess).Sheets(1).Rows("4:4")).Copy Cells(1, 2)
        For i = 1 To Workbooks(namess).Sheets.Count
            With Workbooks(namess).Sheets(i).UsedRange
                If Not IsEmpty(Workbooks(namess).Sheets(i).UsedRange) Then
                    Set cell = Cells(ActiveSheet.UsedRange.Rows.Count + 1, 2)
                    Intersect(.Offset(5, 0), .Cells).Copy cell
                    cell.Resize(.Rows.Count - 5, .Columns.Count) = Intersect(.Offset(5, 0), .Cells).Value
                    cell.Offset(0, -1).Resize(.Rows.Count - 5, 1) = Mid$(VBA.Split(Workbooks(namess).Sheets(i).Range("a2"), "μêÆì¼ò3Æ:")(UBound(VBA.Split(Workbooks(namess).Sheets(i).Range("a2"), "μêÆì¼ò3Æ:"))), 1, 5)
                End If
            End With
        Next i
        Workbooks(namess).Close False
lines:
    Next k
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic  '
End Sub

zhy400137

呃……乱码的地方改成 “店铺简称”

yu88

zhy400137 发表于 2014-5-13 11:42
呃……乱码的地方改成 “店铺简称”

麻烦能传个附件吗，怎么会有乱码

yu88

zhy400137 发表于 2014-5-13 11:42
呃……乱码的地方改成 “店铺简称”

改了好像也不行啊

yu88

还希望解决啊