怎样从上百excel文件中提取固定列中的姓名

哏儿都小伙

有上百个excel表，每个表内格式完全一样，提取固定的某几列中的人员姓名，每列中包含姓名、数字、空行，只提取姓名，然后导到一个Excel表中，每个源excel对应一个sheet，导出的姓名在一列显示

先谢谢大家了，附件内为文件，是自己做的，因原文件是公司文件，实在不方便上传，请大家见谅！

xyxcc177

用ASC值判断，汉字的ASC值都小于0

xyxcc177

lllllllllllllllllllllllllllllllllllll

xyxcc177

Sub getName()
Dim oBook As Workbook

Dim sht As Worksheet
Dim i, k, j As Integer

Dim dic As Object
Dim arr, brr
Set dic = CreateObject("scripting.dictionary")

Sheet1.Range("a:a").ClearContents
Dim path$, file$, str$
path = ThisWorkbook.path & "\"
file = Dir(path & "*.xls*")
   
   Do While file <> ""
   If path & file <> ThisWorkbook.FullName Then
      Set oBook = Application.Workbooks.Open(path & file)
      Set sht = oBook.Worksheets(1)
      For i = 2 To 6 Step 2
        k = sht.Cells(Rows.Count, i).End(xlUp).Row
        arr = sht.Range(sht.Cells(1, i), sht.Cells(k, i)).Value
          For j = 1 To k
            str = arr(j, 1)
            If str <> "" And Len(str) > 1 Then
             If Asc(Mid(str, 1, 1)) < 0 Then
               dic(str) = ""
              End If
             End If
          Next
      Next
       oBook.Close
   End If
   
     file = Dir
   Loop
brr = dic.keys
Sheet1.Range("a1").Resize(dic.Count, 1).Value = Application.Transpose(brr)

End Sub

哏儿都小伙

xyxcc177 发表于 2018-4-5 16:03
Sub getName()
Dim oBook As Workbook

首先感谢您，我确实不太懂vba，还想请教您一下，如果说是从c列，e列，k列提取数据，也是提取名字，这样的话，需要做怎样的修改呢？

xyxcc177

Sub getName()
Dim oBook As Workbook

Dim sht As Worksheet
Dim i, k, j As Integer
Dim colNum
colNum = Array(2, 4, 6)  '取列的序号 b,c,d,e,f (2,3,4,5,6)

Dim dic As Object
Dim arr, brr
Set dic = CreateObject("scripting.dictionary")

Sheet1.Range("a:a").ClearContents
Dim path$, file$, str$
path = ThisWorkbook.path & "\"
file = Dir(path & "*.xls*")
   
   Do While file <> ""
   If path & file <> ThisWorkbook.FullName Then
      Set oBook = Application.Workbooks.Open(path & file)
      Set sht = oBook.Worksheets(1)
      For i = 1 To 3   '几列,如上面，1 to 5
        k = sht.Cells(Rows.Count, colNum(i - 1)).End(xlUp).Row
        arr = sht.Range(sht.Cells(1, colNum(i - 1)), sht.Cells(k, colNum(i - 1))).Value
          For j = 1 To k
            str = arr(j, 1)
            If str <> "" And Len(str) > 1 Then
             If Asc(Mid(str, 1, 1)) < 0 Then
               dic(str) = ""
              End If
             End If
          Next
      Next
       oBook.Close
   End If
   
     file = Dir
   Loop
brr = dic.keys
Sheet1.Range("a1").Resize(dic.Count, 1).Value = Application.Transpose(brr)

End Sub

哏儿都小伙

xyxcc177 发表于 2018-4-5 17:13
Sub getName()
Dim oBook As Workbook

麻烦再问您一下，我改了一下，按完F5，提示有误，您在帮忙看一下

xyxcc177

一定是有其中的列没有数据
Sub getName()
Dim oBook As Workbook

Dim sht As Worksheet
Dim i, k, j As Integer
Dim colNum
colNum = Array(2, 4, 6)  '取列的序号 b,c,d,e,f (2,3,4,5,6)

Dim dic As Object
Dim arr, brr
Set dic = CreateObject("scripting.dictionary")

Sheet1.Range("a:a").ClearContents
Dim path$, file$, str$
path = ThisWorkbook.path & "\"
file = Dir(path & "*.xls*")
   
   Do While file <> ""
   If path & file <> ThisWorkbook.FullName Then
      Set oBook = Application.Workbooks.Open(path & file)
      Set sht = oBook.Worksheets(1)
      For i = 1 To 3   '几列,如上面，1 to 5
        k = sht.Cells(Rows.Count, colNum(i - 1)).End(xlUp).Row
        If k > 1 Then
        arr = sht.Range(sht.Cells(1, colNum(i - 1)), sht.Cells(k, colNum(i - 1))).Value
          For j = 1 To k
            str = arr(j, 1)
            If str <> "" And Len(str) > 1 Then
             If Asc(Mid(str, 1, 1)) < 0 Then
               dic(str) = ""
              End If
             End If
          Next
         End If
      Next
       oBook.Close
   End If
   
     file = Dir
   Loop
brr = dic.keys
Sheet1.Range("a1").Resize(dic.Count, 1).Value = Application.Transpose(brr)

End Sub

哏儿都小伙

xyxcc177 发表于 2018-4-5 19:03
一定是有其中的列没有数据
Sub getName()
Dim oBook As Workbook

不好意思，还是提示相同错误