copyDataToFleetTest1.bas
Option Explicit
Sub copyDataToFleetTest()
Dim n As Long, myarray
Dim shData As Worksheet
Dim shOutput As Worksheet
Worksheets.Add.Name = "FleetMerged"
myarray = Array("ASSOCIATE DIR FLEET MEDICINE", "FISHER BRANCH CLINIC - 237", "OCCUPATIONAL HEALTH MEDICINE", _
"USS TRANQUILITY - 1007")
For n = LBound(myarray) To UBound(myarray)
On Error GoTo eh
' If Not Worksheets(myarray(n)).Name = myarray(n) Then
' 'MsgBox ("Worksheet " & projects(n) & " not found that matches elements in array")
' Worksheets("ZeroFinds").Activate
' Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Value = myarray(n)
'
' Else
' On Error GoTo 0
Set shData = ThisWorkbook.Worksheets(myarray(n))
Set shOutput = ThisWorkbook.Worksheets("FleetMerged")
shData.Activate
Dim rg As Range
Set rg = shData.Range("A1").CurrentRegion
shData.Range("A1").CurrentRegion.Select
Selection.Copy
shOutput.Cells(Rows.Count, 1).End(xlUp).Offset(2, 0).PasteSpecial xlPasteValues
Application.CutCopyMode = False
shOutput.Activate
' enter code to proceed if sheet exists
'End If
Next
eh:
Worksheets("ZeroFinds").Activate
Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Value = myarray(n)
MsgBox ("Worksheet " & myarray(n) & " does not exist, but " & myarray(n) & " exists as an element in your defined array")
End Sub
Video here
Excel sheet here
bas file here
http://www.medical-life-skills.com/Contents/VBA/bas/copyDataToFleetTest1_NL_4.21.22.mp4
http://www.medical-life-skills.com/Contents/VBA/bas/filtered_VistA_4.21.22_fhcc_0922.xlsm
http://www.medical-life-skills.com/Contents/VBA/bas/
http://www.medical-life-skills.com/Contents/VBA/bas/
Slight Variation of above code
Sub copyDataToFleetTest()
Dim n As Long, myarray
Dim shData As Worksheet
Dim shOutput As Worksheet
Worksheets.Add.Name = "FleetMerged"
myarray = Array("ASSOCIATE DIR FLEET MEDICINE", "FISHER BRANCH CLINIC - 237", "OCCUPATIONAL HEALTH MEDICINE", _
"USS TRANQUILITY - 1007")
For n = LBound(myarray) To UBound(myarray)
On Error GoTo eh
' If Not Worksheets(myarray(n)).Name = myarray(n) Then
' 'MsgBox ("Worksheet " & projects(n) & " not found that matches elements in array")
' Worksheets("ZeroFinds").Activate
' Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Value = myarray(n)
'
' Else
' On Error GoTo 0
Set shData = ThisWorkbook.Worksheets(myarray(n))
Set shOutput = ThisWorkbook.Worksheets("FleetMerged")
shData.Activate
Dim rg As Range
Set rg = shData.Range("A1").CurrentRegion
shData.Range("A1").CurrentRegion.Select
Selection.Copy
shOutput.Cells(Rows.Count, 1).End(xlUp).Offset(2, 0).PasteSpecial xlPasteValues
Application.CutCopyMode = False
shOutput.Activate
' enter code to proceed if sheet exists
'End If
Next
eh:
'Worksheets.Add.Name = myarray(n)
'Worksheets(myarray(n)).Activate
'Worksheets(myarray(n)).Range("A1").Value = "No unsigned records found!"
Worksheets("ZeroFinds").Activate
Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Value = myarray(n)
MsgBox ("Worksheet " & myarray(n) & " does not exist, but " & myarray(n) & " exists as an element in your defined array")
End Sub
Select Case MsgBox("Can't undo this action. " & _
"Save workbook first?", vbYesNoCancel)
Case Is = vbYes
ThisWorkbook.Save
Case Is = vbCancel
Exit Sub
End Select
***************
If Not IsEmpty(MyCell) Then
MyCell.Value = Mycell.Value
End If
**************
Dim rg As Range
Set rg = shUSA.Range("A1").CurrentRegion
Dim i As Long
For i = 2 To rg.Rows.Count
If rg.Cells(i, 4) * 2 < 100 Then
Debig.Print rg.Cells(i, 1).Value
End If
Next i
*****************
Sub copyToOtherSheet()
Dim shData As Worksheet, shOutput As Worksheet
Set shData = ThisWorkbook.Worksheets("ASSOCIATE DIR FLEET MEDICINE")
Set shOutput = ThisWorkbook.Worksheets("ZeroFinds")
'shData.Range("A1:F1").Value = shOutput.Range("A2").Value 'this causes shData to now possess shOutput's value
shOutput.Range("A20:F20").Value = shData.Range("A1:F1").Value 'this causes shOutput to now possess shData's value
End Sub
*******************
Sub originContinent()
Dim Origin As String, Region As String
Dim ASPA As Variant, EMEA As Variant
Origin = Cells(1, 1).Value 'enter a value in A1 from the ASPA or EMEA array
ASPA = "CN,AU,HK"
EMEA = "DE,SE,GB"
If InStr(ASPA, Origin) > 0 Then
Region = "Asia"
MsgBox ("Your country is in Asia.")
ElseIf InStr(EMEA, Origin) > 0 Then
Region = "Europe"
MsgBox ("Your country is in Europe.")
ElseIf Origin = "US" Then
Region = "US"
End If
MsgBox Region
End Sub
************
Sub inStr1()
Dim searchString, seachChar, myPos
searchString = Range("F1") 'this is the string that's being searched
seachChar = Range("F2")
myPos = InStr(6, searchString, seachChar)
'myPos = InStr(searchString, seachChar) 'note the 1st argument is optional
MsgBox ("searchChar is at position: " & myPos)
End Sub
InStr("Tech on the Net", "T")
Result: 1 'Shows how start is defaulted to 1 if omitted
InStr(1, "Tech on the Net", "T")
Result: 1
InStr(1, "Tech on the Net", "t")
Result: 9 'Shows that search is case-sensitive
InStr(10, "Tech on the Net", "t")
Result: 15
InStr(1, "Tech on the Net", "the")
Result: 9
InStr(1, "Tech on the Net", "M")
Result: 0 'Shows what is returned if substring is not found
Source: https://www.techonthenet.com/excel/formulas/instr.php
**********
Public Sub Select_Case_Example()
' Read value from cell A1 on YourSheetName
Dim airportCode As String
airportCode = Worksheets("YourSheetName").Range("A1").Value
' Print the name of the airport to the Immediate Window(Ctrl + G)
Select Case airportCode
Case "LHR"
Debug.Print "London Heathrow"
Case "JFK"
Debug.Print "John F Kennedy"
Case "SIN"
Debug.Print "Singapore"
End Select
End Sub
***************
Public Sub If_Example()
' Read value from cell A1 on YourSheetName
Dim airportCode As String
airportCode = Worksheets("YourSheetName").Range("A1").Value
' Print the name of the airport to the Immediate Window(Ctrl + G)
If airportCode = "LHR" Then
Debug.Print "London Heathrow"
ElseIf airportCode = "JFK" Then
Debug.Print "John F Kennedy"
ElseIf airportCode = "SIN" Then
Debug.Print "Singapore"
End If
End Sub
****************
Select Case marks
Case 85 To 100
Debug.Print "High Distinction"
Case 75 To 84
Debug.Print "Distinction"
Case 55 To 74
Debug.Print "Credit"
Case 40 To 54
Debug.Print "Pass"
Case Else
Debug.Print "Fail"
End Select
**************
Select Case marks
Case Is >= 85
Debug.Print "High Distinction"
Case Is >= 75
Debug.Print "Distinction"
Case Is >= 55
Debug.Print "Credit"
Case Is >= 40
Debug.Print "Pass"
Case Else
' For all other marks
Debug.Print "Fail"
End Select
*************
We can have multiple case conditions on one line. We simply use the comma to separate them:
Case Is > 85, 70 To 75, 83
Case 2, 4, 6, 8
Debug.Print "Even numbers"
Case 1, 3, 5, 7
Debug.Print "Odd numbers"
****************