[已解决]数据提取

skiss10086

点击“生成数据”按钮，输入需要分割的值（例如100），按值在B\C列提取起始码与结束码，如果出现尾数时提示（尾数，不够数量），如果数据刚好能除尽就不提示，按钮是模拟其它的代码（有一些代码了）。

最佳答案

月排行榜 / 总排行榜

france723

2017-5-21 19:13

skiss10086 发表于 2017-5-21 18:18
zjdh 老师能帮忙看看吗

简单给你代码修改了一下，你可以在我的代码基础上自己添加修改。

1. Sub 生成数据()
   
2.     Dim vData As Variant, sPath As String
   
3.     Dim nNum As Integer, nI As Integer, nJ As Integer, nRow As Double
   
4.     Dim y, ar, br, cr, n, i
   
5.     ReDim br(1 To 1)
   
6.     ReDim cr(1 To 1)
   
7.     Application.ScreenUpdating = False
   
8.     Application.DisplayAlerts = False
   
9.         sPath = InputBox("请输入需要分隔数据数量：")
   
10.         nNum = Val(sPath)
    
11.         If nNum <> 0 Then
    
12.             ReDim br(1 To 1)
    
13.             ReDim cr(1 To 1)
    
14.             Range("b2:b65536").ClearContents
    
15.             Range("c2:c65536").ClearContents
    
16.             y = Range("a65536").End(3).Row
    
17.             ar = Range("a2:a" & y)
    
18.              For i = 1 To UBound(ar) Step nNum
    
19.                  n = n + 1
    
20.                  ReDim Preserve br(1 To n)
    
21.                  ReDim Preserve cr(1 To n)
    
22.                  br(n) = ar(i, 1)
    
23.                  If (i + nNum - 1) <= y Then
    
24.                     cr(n) = ar(i + nNum - 1, 1)
    
25.                 Else
    
26.                     cr(n) = ar(y - 1, 1) & "不够"
    
27.                 End If
    
28.             Next i
    
29.             Range("b2").Resize(UBound(br), 1) = Application.Transpose(br)
    
30.             Range("c2").Resize(UBound(cr), 1) = Application.Transpose(cr)
    
31.         Else
    
32.             If MsgBox("输入有误或未输入，是否取消输入？", vbYesNo) = vbYes Then GoTo 退出生成数据
    
33.         End If
    
34. 
    
35. 退出生成数据:
    
36.     Application.ScreenUpdating = True
    
37. End Sub

复制代码

跳转到最佳答案楼层

zjdh

你应该举些例子，你的描述无法理解！

skiss10086

zjdh 发表于 2017-5-21 08:06
你应该举些例子，你的描述无法理解！

谢谢你的回复，可能是我没有描述清楚
我在附件中已经举例了，想要实现的是，点击按钮，弹出一个交互窗口（已经有了），输入数量（例如输入100），表格就按照100这个规律来提取起始码与结束码，生成在b列和c列，即起始码是从a2开始的码，结束码为从a2开始的第100个码，第二起始码结束码为101和200，依次类推，

我需要提取的数值不一定是100，可能是300,500，但每次取都按照我输入数量的来提取数据源中对应的起始码和结束码

skiss10086

zjdh 发表于 2017-5-21 08:06
你应该举些例子，你的描述无法理解！

zjdh 老师能帮忙看看吗

france723

skiss10086 发表于 2017-5-21 18:18
zjdh 老师能帮忙看看吗

简单给你代码修改了一下，你可以在我的代码基础上自己添加修改。

1. Sub 生成数据()
   
2.     Dim vData As Variant, sPath As String
   
3.     Dim nNum As Integer, nI As Integer, nJ As Integer, nRow As Double
   
4.     Dim y, ar, br, cr, n, i
   
5.     ReDim br(1 To 1)
   
6.     ReDim cr(1 To 1)
   
7.     Application.ScreenUpdating = False
   
8.     Application.DisplayAlerts = False
   
9.         sPath = InputBox("请输入需要分隔数据数量：")
   
10.         nNum = Val(sPath)
    
11.         If nNum <> 0 Then
    
12.             ReDim br(1 To 1)
    
13.             ReDim cr(1 To 1)
    
14.             Range("b2:b65536").ClearContents
    
15.             Range("c2:c65536").ClearContents
    
16.             y = Range("a65536").End(3).Row
    
17.             ar = Range("a2:a" & y)
    
18.              For i = 1 To UBound(ar) Step nNum
    
19.                  n = n + 1
    
20.                  ReDim Preserve br(1 To n)
    
21.                  ReDim Preserve cr(1 To n)
    
22.                  br(n) = ar(i, 1)
    
23.                  If (i + nNum - 1) <= y Then
    
24.                     cr(n) = ar(i + nNum - 1, 1)
    
25.                 Else
    
26.                     cr(n) = ar(y - 1, 1) & "不够"
    
27.                 End If
    
28.             Next i
    
29.             Range("b2").Resize(UBound(br), 1) = Application.Transpose(br)
    
30.             Range("c2").Resize(UBound(cr), 1) = Application.Transpose(cr)
    
31.         Else
    
32.             If MsgBox("输入有误或未输入，是否取消输入？", vbYesNo) = vbYes Then GoTo 退出生成数据
    
33.         End If
    
34. 
    
35. 退出生成数据:
    
36.     Application.ScreenUpdating = True
    
37. End Sub

复制代码

skiss10086

france723 发表于 2017-5-21 19:13
简单给你代码修改了一下，你可以在我的代码基础上自己添加修改。

谢谢 france723 老师，就是我需要的。

雄鹰2013

Sub 起止数据() '试写
Dim arr, brr
Application.ScreenUpdating = False
On Error Resume Next
x = Val(InputBox("请输入需要分隔数据数量："))
If x <> 0 Then
    With Sheets("核对")
         i = 1
         r = .[a65536].End(3).Row
         arr = .Range("a2:a" & r)
         ReDim brr(1 To UBound(arr), 1 To 2)
         Do While i < r
            n = n + 1
            brr(n, 1) = arr(i, 1)
            brr(n, 2) = arr(i + x - 1, 1)
            If Err.Number <> 0 Then brr(n, 2) = arr(r - 1, 1) & "不够"
            i = i + x
         Loop
         .Range("b2:c10000").ClearContents
         .Range("b2").Resize(n, 2) = brr
    End With
  Else
    If MsgBox("输入有误或未输入，是否取消输入？", vbYesNo) = vbYes Then GoTo 100
  End If
100:
Application.ScreenUpdating = True
End Sub

雄鹰2013

学习着写了一个