[已解决]关于删除数据的代码求助，在线等，急用

grf1973 · 发表于 2015-9-24 15:57

要清理一下待提取的表，只能按附件的表式，不然没法操作。
也可以在前面加一句 on error resume next，忽略出错部分。

grf1973 · 发表于 2015-9-24 16:02

剩下三列没注意，不过不知道对应提取表里的什么内容。
可自行参照  brr(n, 5) = Sht.[I4] 往下写

这里的  brr(n, x)  中，x表示数据表里的列数
[I4]  表示提取表中含此内容的单元格。

坏也是一种态度 · 发表于 2015-9-24 17:17

grf1973 发表于 2015-9-24 16:02
剩下三列没注意，不过不知道对应提取表里的什么内容。
可自行参照 brr(n, 5) = Sht. 往下写

嗯嗯好滴，我照你这样写的改下，遇到什么问题的话，找你，真是十分感谢大侠了，需要向你多多学习啊

坏也是一种态度 · 发表于 2015-9-24 21:46

grf1973 发表于 2015-9-24 15:57
要清理一下待提取的表，只能按附件的表式，不然没法操作。
也可以在前面加一句 on error resume next，忽略 ...

大侠这一句应该加在哪里

grf1973 · 发表于 2015-9-25 10:00

加在一开始

坏也是一种态度 · 发表于 2015-9-25 14:48

grf1973 发表于 2015-9-25 10:00
加在一开始

大侠看下我这改的代码，但为什么备注和个人简介，尺码什么的数据还是取不到数据呐
代码可以正常运行是不假

Sub 导入文件()
Application.ScreenUpdating = False
Dim Filename, wb As Workbook, Sht As Worksheet
Filename = Dir(ThisWorkbook.Path & "\*.xls")
Dim brr(1 To 1000, 1 To 18) ''''''''''''''改到适当的列数
Do While Filename <> ""
      If Filename <> ThisWorkbook.Name Then
         fn = ThisWorkbook.Path & "\" & Filename
         Set wb = Workbooks.Open(fn)
         For Each Sht In wb.Worksheets
            n = n + 1
            brr(n, 2) = Sht.[b3]    '姓名
            brr(n, 5) = Sht.[I4]    '手机号
            brr(n, 14) = Sht.[F3]    '籍贯
            brr(n, 18) = Sht.[I7]    '个人简介
            If Len(Sht.[M3]) > 0 Then
                  brr(n, 5) = Sht.[M3] '最佳联系方式
                  brr(n, 7) = Sht.[d3]    '生日
                  arr = Sht.Range("a19:i30")
            For i = 2 To UBound(arr)
                  If Len(arr(i, 1)) = 0 Then
                     arr(i, 1) = arr(i - 1, 1)
                     jf = arr(i, 8)    '积分
                     If jf > 0 Then
                        nf = Left(arr(i, 1), 4)    '年
                        If nf = "2015" Then
                              brr(n, 8) = brr(n, 8) + jf    '2015年积分
                              If nf = "2014" Then
                                 brr(n, 9) = brr(n, 9) + jf    '2014年积分
                              End If
                        End If '''''''''''''缺少
                     End If '''''''''''''缺少
                  End If '''''''''''''缺少
            Next
            End If '''''''''''''缺少
         Next
         wb.Close False
      End If
      Filename = Dir
Loop
Set Sht = Nothing
r = [b65536].End(3).Row + 1
If n > 0 Then Cells(r, 1).Resize(n, 12) = brr
Application.ScreenUpdating = True
End Sub

grf1973 · 发表于 2015-9-25 16:53

小改了一下。

Sub 导入文件()
Application.ScreenUpdating = False
Dim Filename, wb As Workbook, Sht As Worksheet
Filename = Dir(ThisWorkbook.Path & "\*.xls")
Dim brr(1 To 1000, 1 To 18)
Do While Filename <> ""
If Filename <> ThisWorkbook.Name Then
fn = ThisWorkbook.Path & "" & Filename
Set wb = Workbooks.Open(fn)
For Each Sht In wb.Worksheets
If Sht.[b3] <> "" Then '有姓名才运行
n = n + 1
brr(n, 2) = Sht.[b3] '姓名
brr(n, 5) = Sht.[I4] '手机号
brr(n, 14) = Sht.[F3] '籍贯
brr(n, 18) = Sht.[I7] '个人简介
If Len(Sht.[M3]) > 0 Then brr(n, 5) = Sht.[M3] '最佳联系方式
brr(n, 7) = Sht.[d3] '生日
arr = Sht.Range("a19:i30")
For i = 2 To UBound(arr)
If Len(arr(i, 1)) = 0 Then arr(i, 1) = arr(i - 1, 1)
jf = Val(arr(i, 8)) '积分
If jf > 0 Then
nf = Left(arr(i, 1), 4) '年
If nf = "2015" Then brr(n, 8) = brr(n, 8) + jf '2015年积分
If nf = "2014" Then brr(n, 9) = brr(n, 9) + jf '2014年积分
End If
Next
End If
Next
wb.Close False
End If
Filename = Dir
Loop
Set Sht = Nothing
r = [b65536].End(3).Row + 1
If n > 0 Then Cells(r, 1).Resize(n, 18) = brr
Application.ScreenUpdating = True
End Sub

复制代码

grf1973 · 发表于 2015-9-25 16:56

请看附件。

坏也是一种态度 · 发表于 2015-9-25 22:36

grf1973 发表于 2015-9-25 16:56
请看附件。

十分感谢你呀
真是帮了我大忙了

坏也是一种态度 · 发表于 2015-9-30 16:37

grf1973 发表于 2015-9-25 16:56
请看附件。

大侠你看下这个简单需求
就是除了保留A列字母外从C列开始，所有奇数列字母都删除
这代码应该怎么写
有几百个这样表呐

		自动登录	找回密码
密码			注册