Question

以下是我的代码;我尝试将列的代码数据拆分为不同的工作表。我的问题是;我需要输入一个新的条件来从列订单;我每次存储1-50000特定值范围的数字并生成最终的工作表。

例如：我希望表格“101”“102”“501”包含来自“订单”栏目仅的数据，值为＆gt; 0<=value and value=<50。

The "value" to be populated by the user=> "Please Insert Orders from"=> 0 
                                          "Please Insert Orders up to"=>50

事先提前！

data

Private Sub Run_Click()

Dim LR As Long
Dim ws As Worksheet
Dim vCol, i, j As Integer
Dim icol As Long
Dim MyArr As Variant
Dim title As String
Dim titlerow As Integer



'1-store user input in 'Fullo' variable
Dim Fullo As String
Fullo = InputBox("Please insert sheet of analysis:", "Collect User Input")

'test input before continuing to validate the input
If Not (Len(Fullo) > 0) Then
    MsgBox "Input not valid, code aborted.", vbCritical
    Exit Sub
End If

'2-store user input in 'CN' variable
Dim CN As Integer
CN = InputBox("Please insert column of analysis:", "Collect User Input")

'test input before continuing to validate the input
If Not (Len(CN) > 0 And IsNumeric(CN)) Then
    MsgBox "Input not valid, code aborted.", vbCritical
    Exit Sub
End If

'3-store user input in 'CN' variable
Dim HKFrom As Integer
HKFrom = InputBox("Please insert Orders from:", "Collect User Input")

'test input before continuing to validate the input
If Not (Len(HKFrom) > 0 And IsNumeric(HKFrom)) Then
    MsgBox "Input not valid, code aborted.", vbCritical
    Exit Sub
End If

'4-store user input in 'CN' variable
Dim HKUntil As Integer
HKUntil = InputBox("Please insert Orders up to:", "Collect User Input")

'test input before continuing to validate the input
If Not (Len(HKUntil) > 0 And IsNumeric(HKUntil)) Then
    MsgBox "Input not valid, code aborted.", vbCritical
    Exit Sub
End If


vCol = CN
Set ws = Sheets(Fullo)
'Spot bottom row of data
LR = ws.Cells(ws.Rows.Count, vCol).End(xlUp).Row
'Range where titles are across top of data, as string, data MUST
'have titles in this row, edit to suit your titles locale
title = "A1:H1"
titlerow = ws.Range(title).Cells(1).Row
icol = ws.Columns.Count
ws.Cells(1, icol) = "Unique"


For i = 2 To LR
On Error Resume Next
If ws.Cells(i, vCol) <> "" And Application.WorksheetFunction.Match(ws.Cells(i, vCol), ws.Columns(icol), 0) = 0 Then
ws.Cells(ws.Rows.Count, icol).End(xlUp).Offset(1) = ws.Cells(i, vCol)
End If

'error handling
Next
MyArr = Application.WorksheetFunction.Transpose(ws.Columns(icol).SpecialCells(xlCellTypeConstants))
ws.Columns(icol).Clear


For i = 2 To UBound(MyArr)
ws.Range(title).AutoFilter Field:=vCol, Criteria1:=MyArr(i) & ""
If Not Evaluate("=ISREF('" & MyArr(i) & "'!A1)") Then
Sheets.Add(After:=Worksheets(Worksheets.Count)).Name = MyArr(i) & ""
Else
Sheets(MyArr(i) & "").Move After:=Worksheets(Worksheets.Count)
End If
ws.Range("A" & titlerow & ":A" & LR).EntireRow.Copy Sheets(MyArr(i) & "").Range("A1")
Sheets(MyArr(i) & "").Columns.AutoFit

Next
ws.AutoFilterMode = False
ws.Activate

End Sub

根据另一列中的条件拆分excel中的列

0 个答案: