VBA

时间：2018-09-19 12:31:57

标签： excel vba excel-vba

我正在尝试制作一个简单的工具来报告工作地点的结果。为此，宏需要接受将由宏处理的.csv文件。到目前为止没有问题。我得到了预期的效果，也许不是完全按照VBA程序员的标准，但是可以正常工作。

不过，我目前有一点要解决。 A列和E列需要对齐，因为使用宏时，同事可以轻松地对结果进行后续处理。

有3种不同的情况，其中有两种是我能解决的。

  1. 需要在同一行上对齐两组结果（A和E列（部分填充）（可以正常工作）
  2. 因为仅填充了A列，所以不需要一组结果对齐（可正常工作）
  3. 不需要一组结果对齐，因为仅应填充E列（宏不起作用）

A列和E列固定用于我要分配给这些列的特定结果。

我收到运行时错误1004'未找到任何单元格'，请查看下面我一直在使用的代码。

Sub Report()


Dim csvFileName As Variant
Dim destCell As Range
Dim rdata As Worksheet
Dim Test1Test2reportxl As Workbook
Dim tTest2 As Worksheet
Dim tTest1 As Worksheet

For Each aSheet In Worksheets

Set Test1Test2reportxl = ThisWorkbook
'Hide sheet
' Set Generate = Sheets("Generate")
' Generate.Visible = False


'Delete previous sheets with same name
Select Case aSheet.Name

    Case "rdata"
        Application.DisplayAlerts = False
        aSheet.Delete
        Application.DisplayAlerts = True

    Case "Test1Test2report"
        Application.DisplayAlerts = False
        aSheet.Delete
        Application.DisplayAlerts = True

    Case "tTest2"
        Application.DisplayAlerts = False
        aSheet.Delete
        Application.DisplayAlerts = True

    Case "tTest1"
        Application.DisplayAlerts = False
        aSheet.Delete
        Application.DisplayAlerts = True



    Case "TitlePage"
        Application.DisplayAlerts = False
        aSheet.Delete
        Application.DisplayAlerts = True

End Select

Application.ScreenUpdating = False


'Add new Test1Test2report and rdata sheet

Next

Dim wb12 As Workbook
Dim ws12 As Worksheet, wsNEW As Worksheet
Dim Test1Test2report As String

'checking if sheet already exists in workbook
Set wb12 = ActiveWorkbook

For Each ws12 In wb12.Worksheets
    If ws12.Name = "Test1Test2report" Then
        Exit Sub
    End If
Next ws12

Sheets("Template").Visible = True

Worksheets("Template").Copy After:=Worksheets(Worksheets.Count) 'move to end

Set wsNEW = ActiveSheet

wsNEW.Name = "Test1Test2report"

Sheets("Template").Visible = False

'MsgBox ("Working so far!")
'new sheet required



Sheets.Add(After:=Sheets(Sheets.Count)).Name = "rdata"
Sheets.Add(After:=Sheets(Sheets.Count)).Name = "tTest2"
Sheets.Add(After:=Sheets(Sheets.Count)).Name = "tTest1"

 'Import .csv file data

Set destCell = Worksheets("rdata").Cells(Rows.Count, 
"A").End(xlUp).Offset(1)      'CHANGE SHEET NAME
ChDrive "H:\"
    ChDir "H:\Virology Shared Documents\Artus Test1 PCR results\CSV 
 Test1Test2 PCR"
csvFileName = Application.GetOpenFilename(fileFilter:="CSV Files 
(*.csv),*.csv", Title:="Select a CSV File", MultiSelect:=False)
    If csvFileName = False Then


    Application.DisplayAlerts = False
    Worksheets("rdata").Delete
    Worksheets("tTest2").Delete
    Worksheets("tTest1").Delete
    Worksheets("Test1Test2report").Delete
    Application.DisplayAlerts = True

    MsgBox "File select was stopped, because you did not select the right 
    file type :-(, please select the right CSV file to proceed!"

    Exit Sub

End If

With destCell.Parent.QueryTables.Add(Connection:="TEXT;" & csvFileName, 
Destination:=destCell)
    .TextFileStartRow = 1
    .TextFileParseType = xlDelimited
    .TextFileCommaDelimiter = True
    .Refresh BackgroundQuery:=False
End With

destCell.Parent.QueryTables(1).Delete

' Hide columns in rdata sheet

Set rdata = Sheets("rdata")

Range("D:D, H:L").EntireColumn.Hidden = True
rdata.Visible = True

' Add headers to Test1Test2report sheet

Sheets("Generate").Range("A1:D1").Copy Sheets("tTest1").Range("A1:D1")
Sheets("Generate").Range("A2:D2").Copy Sheets("tTest2").Range("A1:D1")
Sheets("Generate").Range("A4:I4").Copy 
Sheets("Test1Test2report").Range("A1:I1")

    'Test1 data selection and copy to tTest1 sheet

Sheets("rdata").Select

On Error GoTo Test2

If Cells.Find(What:="range test 1)", _
After:=ActiveCell, LookIn:=xlFormulas, LookAt:= _
xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
, SearchFormat:=False).Activate Then

ActiveCell.Offset(3, 1).Select

Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Sheets("tTest1").Select
Range("A2").Select
ActiveSheet.Paste

Sheets("rdata").Select
Selection.Offset(0, 1).Select
Selection.Copy
Sheets("tTest1").Select
Range("D2").Select
ActiveSheet.Paste

End If

Sheets("rdata").Select

On Error GoTo Test2

If Cells.Find(What:="2nd range test 1)", _
After:=ActiveCell, LookIn:=xlFormulas, LookAt:= _
xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
, SearchFormat:=False).Activate Then

ActiveCell.Offset(3, 1).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Offset(0, 1).Select
Selection.Copy
Sheets("tTest1").Select
Range("C2").Select
ActiveSheet.Paste

Sheets("rdata").Select
Selection.Offset(0, 3).Select
Selection.Copy
Sheets("tTest1").Select
Range("B2").Select
ActiveSheet.Paste



End If

 'Test2 data selection and copy to tTest2 sheet


Sheets("rdata").Select

   Test2:

On Error GoTo SheetSelect

If Cells.Find(What:="range test 2)", _
After:=ActiveCell, LookIn:=xlFormulas, LookAt:= _
xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
, SearchFormat:=False).Activate Then

ActiveCell.Offset(3, 1).Select

Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Sheets("tTest2").Select
Range("A2").Select
ActiveSheet.Paste

Sheets("rdata").Select
Selection.Offset(0, 1).Select
Selection.Copy
Sheets("tTest2").Select
Range("D2").Select
ActiveSheet.Paste

End If


Sheets("rdata").Select

On Error GoTo SheetSelect

If Cells.Find(What:=2nd range test 2)", _
After:=ActiveCell, LookIn:=xlFormulas, LookAt:= _
xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
, SearchFormat:=False).Activate Then

ActiveCell.Offset(3, 1).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Offset(0, 1).Select
Selection.Copy
Sheets("tTest2").Select
Range("C2").Select
ActiveSheet.Paste

Sheets("rdata").Select
Selection.Offset(0, 3).Select
Selection.Copy
Sheets("tTest2").Select
Range("B2").Select
ActiveSheet.Paste

End If

If Err.Number <> 0 Then

    Application.DisplayAlerts = False
    Worksheets("rdata").Delete
    Worksheets("tTest2").Delete
    Worksheets("tTest1").Delete
    Worksheets("Test1Test2report").Delete
    Application.DisplayAlerts = True

    MsgBox "You did not select a Test1/Test2 PCR .csv file, please try 
    again!"

End If

Resume

    ' Select data tTest1/tTest2 and copy to Test1Test2report sheet

SheetSelect:

Sheets("tTest1").Select

With Worksheets("tTest1")
lastrow = .Cells(Rows.Count, "A").End(xlUp).Row
.Range("A2:D" & lastrow).Select

Selection.Copy

Sheets("Test1Test2report").Select
Range("A2").Select
ActiveSheet.Paste

End With

Sheets("tTest2").Select

With Worksheets("tTest2")
lastrow = .Cells(Rows.Count, "A").End(xlUp).Row
.Range("A2:D" & lastrow).Select

Selection.Copy

Sheets("Test1Test2report").Select
Range("E2").Select
ActiveSheet.Paste

End With

 'Hide data sheets

'Application.DisplayAlerts = False

'Set tTest1 = Sheets("tTest1")
'tTest1.Visible = False

'Set tTest2 = Sheets("tTest2")
'tTest2.Visible = False

'Set rdata = Sheets("rdata")
'rdata.Visible = False

'Application.DisplayAlerts = True

'Summary:   Align codes in columns C and D removing all D values not in C
Dim i As Long, lr As Long

Application.ScreenUpdating = False

     'Last row with data in column F
lr = Range("F" & Rows.Count).End(xlUp).Row

    'Sort both section so numbers are ascending in E and F
Columns("A:D").Sort Key1:=Range("A2"), Order1:=xlAscending, _
    Header:=xlYes, OrderCustom:=1, MatchCase:=False, _
    Orientation:=xlTopToBottom, DataOption1:=xlSortNormal
Columns("E:H").Sort Key1:=Range("E2"), Order1:=xlAscending, _
    Header:=xlYes, OrderCustom:=1, MatchCase:=False, _
    Orientation:=xlTopToBottom, DataOption1:=xlSortNormal

  'line up remaining items so A lines up with E

i = 2
Do
    If Cells(i, "A") > Cells(i, "E") And Cells(i, "E") > "" Then
        Cells(i, "A").Resize(1, 4).Insert xlShiftDown
    ElseIf Cells(i, "A") < Cells(i, "E") And Cells(i, "A") > "" Then
        Cells(i, "E").Resize(1, 4).Insert xlShiftDown
    End If
    i = i + 1
Loop Until Cells(i, "A") = "" And Cells(i, "E") = ""
    With Intersect(Columns("A"), ActiveSheet.UsedRange)
    .Replace "QS*", "#N/A", xlPart
    On Error Resume Next
    .SpecialCells(xlCellTypeConstants, xlErrors).EntireRow.Delete
    On Error GoTo 0

    End With

.SpecialCells(xlConstants, xlErrors).EntireRow.Delete引起了错误，到目前为止，Google并没有帮助我为此找到合适的答案。

1 个答案:

答案 0 :(得分：0)

首先在评论中添加此内容，但要发表的评论超出其允许范围。

您确定是.SpecialCells(xlCellTypeConstants, xlErrors)而不是.SpecialCells(xlCellTypeFormulas, xlErrors)吗？也可能只想检查一下，以确保在删除特殊单元格之前，该特殊单元格相交没有。

我在xlCelltypeConstants上遇到1004错误，但是如果我将xlCellTypeFormulas放在一个相交的单元格中，=na()对我有用。

If Not Intersect(Columns("A"), ActiveSheet.UsedRange).SpecialCells(xlCellTypeFormulas, xlErrors) Is Nothing Then
    Intersect(Columns("A"), ActiveSheet.UsedRange).SpecialCells(xlCellTypeFormulas, xlErrors).EntireRow.Delete
End If
相关问题
最新问题