Я работал над другой программой, в которой я беру конкретные данные из рабочего листа и вставляю их в определенный лист в рабочей книге, в зависимости от того, какой тип детали находится в данных в первом рабочем листе.
Чтобы иметь возможность расшифровать, какой лист будет вызван, мне нужно было написать операторы If, чтобы определить, основываясь на значении ячейки "тип детали", какой лист будет вызван и может быть вставлен.Поскольку задействовано примерно 4 подпрограммы (копирование и вставка даты, времени, типа детали и определенной силы нажатия), у меня было IF операторов в каждой отдельной подпрограмме, и он просто вызывал подпрограммы индивидуально.
Чтобы сократить это, и просто вызывать «Правильный рабочий лист» в начале каждого подпункта, не используя другой оператор IF, я пытался задать для рабочего листа переменную, как вы увидите ниже:
With ActiveWorkbook
If CaseBRH = True Then
CorrectFile = Sheets("Case B Left Hand")
ElseIf CaseBLH = True Then
CorrectFile = Sheets("Case B Right Hand")
ElseIf Feedshaft = True Then
CorrectFile = Sheets("Feedshaft")
End If
CorrectFile - это переменная, которую я определил как Public перед первой подпрограммой Sub.
В основном я использовал StrComp и Find if CaseBLH, CaseBRH или FeedshaftЭто правда, и эта часть работала до тех пор, пока я не сделал эти изменения.
Проблема теперь в том, что, когда я добираюсь до такой строки:
Workbooks("Consolidated Diagramm Data.xlsx").Activate
CorrectFile.Activate
Range("C1").PasteSpecial Transpose:=True
Application.CutCopyMode = False
Она выпрыгивает изподпрограмма полностью после завершения строки CorrectFile.Activate и перехода к следующему подпункту, и она не вызывает правильный лист.Любые предложения?
Ниже весь модуль:
Public Path As String
Public Counter As Integer
Public LHCounter As Integer
Public RHCounter As Integer
Public FeedshaftCounter As Integer
Public NameFile As Workbook
Public Feedsft As String
Public RightHand As String
Public LeftHand As String
Public Feedshaft As Boolean
Public CaseBRH As Boolean
Public CaseBLH As Boolean
Public Celltxt As String
Public MyFolder As String 'Path collected from the folder picker dialog
Public MyFile As String 'Filename obtained by DIR function
Public wbk As Workbook 'Used to loop through each workbook
Public thisWb As Workbook
Public CorrectFile As Worksheet
Sub Consolidate_Diagramms_Data()
Set NameFile = Workbooks.Add
Dim wb As Workbook
Application.DisplayAlerts = False
NameFile.SaveAs FileName:="C:\DataAnalyzation\Consolidated Diagramm Data.xlsx"
Set wb = ActiveWorkbook
Sheets("Sheet1").Name = "Case B Left Hand"
Worksheets.Add().Name = "Case B Right Hand"
Worksheets.Add().Name = "Feedshaft"
Call AllWorkbooks
End Sub
Sub AllWorkbooks()
Set thisWb = ActiveWorkbook
On Error Resume Next
Application.ScreenUpdating = False 'Opens the folder picker dialog to allow user selection
MsgBox "Please select the folder from which you wish to consolidate your data."
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Please select a folder"
.Show
.AllowMultiSelect = False
If .SelectedItems.Count = 0 Then 'If no folder is selected, abort
MsgBox "You did not select a folder"
Exit Sub
End If
MyFolder = .SelectedItems(1) & "\" 'Assign selected folder to MyFolder
End With
Counter = 0
LHCounter = 0
RHCounter = 0
FeedshaftCounter = 0
MyFile = Dir(MyFolder) 'DIR gets the first file of the folder
'Loop through all files in a folder until DIR cannot find anymore
Do While MyFile <> ""
Counter = Counter + 1
Set wbk = Workbooks.Open(FileName:=MyFolder & MyFile)
Application.ScreenUpdating = False
EventState = Application.EnableEvents
Application.EnableEvents = False
CalcState = Application.Calculation
Application.Calculation = xlCalculationManual
PageBreakState = ActiveSheet.DisplayPageBreaks
ActiveSheet.DisplayPageBreaks = False
Feedsft = "Feed Shaft"
RightHand = "Case B Right Hand"
LeftHand = "Case B Left Hand"
Celltxt = Range("D2").Value
If StrComp(Celltxt, Feedsft, vbTextCompare) = 0 Then
CaseBLH = False
CaseBRH = False
Feedshaft = True
FeedshaftCounter = FeedshaftCounter + 1
ElseIf StrComp(Celltxt, LeftHand, vbTextCompare) = 0 Then
Feeshaft = False
CaseBRH = False
CaseBLH = True
LHCounter = LHCounter + 1
ElseIf StrComp(Celltxt, RightHand, vbTextCompare) = 0 Then
Feedshaft = False
CaseBLH = False
CaseBRH = True
RHCounter = RHCounter + 1
End If
With ActiveWorkbook
If CaseBRH = True Then
Set CorrectFile = Sheets("Case B Left Hand")
ElseIf CaseBLH = True Then
Set CorrectFile = Sheets("Case B Right Hand")
ElseIf Feedshaft = True Then
Set CorrectFile = Sheets("Feedshaft")
End If
End With
If Feedshaft = True And FeedshaftCounter = 1 Then 'If it is a Feedshaft and this is the first part of that part type
Call Copy_Position
Call Paste_Position
Call Copy_Paste_Date
Call Copy_PartType
Call Paste_PartType
ElseIf CaseBLH = True And LHCounter = 1 Then 'If it is a Case B LH and this is the first part of that part type
Call Copy_Position
Call Paste_Position
Call Copy_Paste_Date
Call Copy_PartType
Call Paste_PartType
ElseIf CaseBRH = True And RHCounter = 1 Then 'If it is a Case B RH and this is the first part of that part type
Call Copy_Position
Call Paste_Position
Call Copy_Paste_Date
Call Copy_PartType
Call Paste_PartType
End If
Call Copy_Paste_Force
wbk.Close savechanges:=False
MyFile = Dir 'DIR gets the next file in the folder
Loop
Application.DisplayAlerts = True
Application.ScreenUpdating = True
MsgBox ("A total of " & Counter & " files have been consolidated. This includes " & LHCounter & " Left Hand Part(s), " & RHCounter & " Right Hand Part(s) and " & FeedshaftCounter & " Feedshaft(s).")
End Sub
Sub Copy_Position()
Range("C4").Activate
Range(ActiveCell, ActiveCell.End(xlDown)).Copy 'Copies the Part Type displayed in Cell C4
End Sub
Sub Paste_Position()
If Range("C4") = "" Then
MsgBox ("There is no data in this file") 'Checks for an empty value in Cell C4
End If
Workbooks("Consolidated Diagramm Data.xlsx").Activate 'Activates Workbook
CorrectFile.Range("C1").PasteSpecial Transpose:=True 'Pastes Position data into a Row, starting at Column C
Application.CutCopyMode = False
End Sub
Sub Copy_Paste_Date()
Workbooks(MyFile).Activate 'Activates the Data Sheet
ActiveSheet.Range("B2").Copy 'Copies the Date
Workbooks("Consolidated Diagramm Data.xlsx").Activate 'Activates the final Workbook
CorrectFile.Range("A2").PasteSpecial Paste:=xlPasteAll 'Pastes the Date into "A2"
Application.CutCopyMode = False
End Sub
Sub Copy_PartType()
Workbooks(MyFile).Activate 'Activates Data Sheet
ActiveSheet.Range("D2").Copy 'Copies part type
End Sub
Sub Paste_PartType()
If Range("D2") = "" Then
MsgBox ("There is no data in this file") 'Checks for no values in "D2"
End If
Workbooks("Consolidated Diagramm Data.xlsx").Activate 'Activates the Correct
CorrectFile.Range("B2").PasteSpecial Paste:=xlPasteAll 'Pastes the part type into "B2"
Application.CutCopyMode = False
End Sub
Sub Copy_Paste_Force()
Dim CR As Long
Dim Cpy As Range
Workbooks(MyFile).Activate 'Calls up the Data Sheet
Range("D4").Activate
Range(ActiveCell, ActiveCell.End(xlDown)).Copy 'Copies Force Values
If Range("D4") = "" Then
MsgBox ("There is no data in this file") 'Checks for no values in "D4"
End If
Workbooks("Consolidated Diagramm Data.xlsx").Activate
If Feedshaft = True And FeedshaftCounter = 1 Then 'If it is Feedshaft and no parts have been pasted
GoTo PasteInitial
ElseIf Feedshaft = True And FeedshaftCounter > 1 Then 'If it is Feedshaft and one part has already been pasted
GoTo PasteAfter
ElseIf CaseBLH = True And LHCounter = 1 Then 'If it is Case B LH and no parts have been pasted
GoTo PasteInitial
ElseIf CaseBLH = True And LHCounter > 1 Then 'If it is Case B LH and one part has already been pasted
GoTo PasteAfter
ElseIf CaseBRH = True And RHCounter = 1 Then 'If it is Case B RH and no parts have been pasted
GoTo PasteInitial
ElseIf CaseBRH = True And RHCounter > 1 Then 'If it is Case B RH and one part has already been pasted
GoTo PasteAfter
End If
PasteInitial: 'Pastes the first force values into Column C underneath the vertical position
Range("C2").Activate
ActiveCell.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
Application.CutCopyMode = False
GoTo Nd
PasteAfter: 'After the first force value is Pasted, this searches for the last row, offsets, and pastes into the next empty row
CR = Cells(Rows.Count, "C").End(xlUp).Row
Range(CR).Activate
ActiveCell.Offset(1, 0).Select
ActiveCell.PasteSpecial Transpose:=True
Application.CutCopyMode = False
GoTo Nd
Nd:
End Sub