问题
I've been working on another program where I am taking specific data from a worksheet, and paste it into a certain sheet on a workbook, depending on what the part type is that is found on the data in the first worksheet.
To be able to decipher which sheet will be called up, I had to write If statements to determine, based on the "part type" cell value, which sheet would be called and could be pasted into. Since there is approximately 4 subs involved (copy and pasting the date, the time, part type and the specific pressing force), I had IF statements in every single sub, and it would just call the subs individually.
To shorten this, and just call the "Correct Worksheet" at the beginning of every sub without having to use another IF statement, I've been trying to set the Worksheet to a variable, as you'll see below:
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 is a variable that I've defined as a Public before the first Sub routine.
Basically what I did was use a StrComp and Find if CaseBLH, CaseBRH, or Feedshaft is true, and that part was working up until I made these changes.
The problem is now that when I get to a line like this one:
Workbooks("Consolidated Diagramm Data.xlsx").Activate
CorrectFile.Activate
Range("C1").PasteSpecial Transpose:=True
Application.CutCopyMode = False
It jumps out of the sub completely after completing the CorrectFile.Activate line and goes onto the next sub, and it does not call the correct worksheet. Any suggestions?
Below is the entire Module:
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
来源：https://stackoverflow.com/questions/53618389/setting-excel-worksheet-to-a-variable-and-calling-the-variable-in-a-different-s