Hi I have been trying to join together several macros to automate a process which involves importing data files from text and copying parts of the data to a "core sheet". My problem arises when i try to use the "For Each loop" to move through the sheets check a condition and if the condition is met run the data extraction macro. Basically the macro does not loop, i researched various solutions but nothing worked. It works fine the first time it is run (usualy the sheet that is displayed meets the conditions so it moves on to the "shima" macro) however then the "core sheet" is displayed and since this does not meet the conditions i just want it to move on to the next sheet but it doesn't. Code is below let me know if any of this is unclear.
Sub FullAuto()
Call Module1.Myfolderselector 'this macro imports all the text file in a given folder
Dim Msg, Style, Title, Response, MyString
Public ws As Worksheet
Msg = "Yes for Fluorescence, No for UV"
Style = vbYesNo + vbCritical + vbDefaultButton1
Title = "Choose data"
'this parts asks the user which type of Data they want to import
Response = MsgBox(Msg, Style, Title)
If Response = vbYes Then
MyString = "Yes"
Else
MyString = "No"
End If
For Each ws In Worksheets 'this is the part with issues.
If MyString = "Yes" And Range("A1").Value <> "Core" Then
Call Module1.Detector_B_Shima_9_0
ElseIf MyString = "No" And Range("A1").Value <> "Core" Then
Call Module1.Detector_A_Shima_9_1
End If
Next ws
Worksheets.Add(After:=Worksheets(1)).Name = "Plot Sheet"
End Sub
Sub Detector_B_Shima_9_0()
Cells.Select
Selection.Find(What:="[LC Chromatogram(Detector B-Ch1)]", After:=ActiveCell _
, LookIn:=xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, _
SearchDirection:=xlNext, MatchCase:=False).Activate
ActiveCell.Offset(9, 1).Select
ActiveCell.Value = Range("B20")
Range(ActiveCell, Cells(ActiveCell.Row + 8401, ActiveCell.Column)).Select
Selection.Copy
Sheets("Core Sheet").Select
Range("C3").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
ActiveCell.EntireColumn.Insert
End Sub
Try to change this code:
For Each ws In Worksheets 'this is the part with issues.
If MyString = "Yes" And Range("A1").Value <> "Core" Then
Call Module1.Detector_B_Shima_9_0
ElseIf MyString = "No" And Range("A1").Value <> "Core" Then
Call Module1.Detector_A_Shima_9_1
End If
Next ws
to the next one
For Each ws In Worksheets
If MyString = "Yes" And ws.Range("A1").Value <> "Core" Then
Call Module1.Detector_B_Shima_9_0
ElseIf MyString = "No" And ws.Range("A1").Value <> "Core" Then
Call Module1.Detector_A_Shima_9_1
End If
Next ws
Note, that I've added ws. before Range("A1") : ws.Range("A1").Value. This little improvment helps VBA to understand, that Range("A1") belongs to worksheet ws.
Related
I have been working on this tool inventory system for the shop I work at (machine shop).
Earlier today things were working ok, pretty much got it all running, was just spending some time debugging and cleaning up. Suddenly it's not working. I wasn't working in this area I don't recall but somehow I'm getting a type mismatch. I'm lost on this one.
I get a mismatch type on if activecell.value <> x then.
Sub createOrder_BTN()
Dim x As String
Dim found As Boolean
Dim lRow As Long
Application.ScreenUpdating = False
Worksheets("Orders").Activate
Worksheets("Orders").Range("A4").Activate
'change to master sheet
Worksheets("Master").Activate
' Select first line of data.
Range("U3").Select
' Set search variable value.
x = ""
' Set Boolean variable "found" to false.
found = False
' Set Do loop to stop at empty cell.
Do Until IsEmpty(ActiveCell)
' change to master sheet
Worksheets("Master").Activate
' Check active cell for search value.
If ActiveCell.Value <> x Then
found = True
'MsgBox "Value found in cell " & ActiveCell.Address
ActiveCell.EntireRow.Copy
Worksheets("Orders").Activate
lRow = Cells.Find(What:="", _
After:=Range("A4"), _
LookAt:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
ActiveCell.Offset(1).Select
ActiveCell.PasteSpecial
End If
' change to master sheet
Worksheets("Master").Activate
' Step down 1 row from present location.
ActiveCell.Offset(1, 0).Select
Loop
Application.ScreenUpdating = True
Worksheets("Orders").Activate
End Sub
I have four or five macro's each copying and pasting different subsets of data (all defined as ranges) from one tab to another tab. Occasionally someone may need to change some of the pasted data or rather portions of this.
Each of these macro's contains defined points I can goto. BUT if I needed to get to these points from another macro without running the bit before the goto point in the target macro - how can I do this.
I can call or application.run the second macro, but I need only run a part of it, not the whole thing.
I am a bit stuck.
Here is the part of the code which defines the goto point in one of the target macro's.
Grade:
Grades = Application.InputBox("Which Grade chemistry do you wish to load & Check against" & vbLf & vbLf & "1. S355 J2H" & vbLf & vbLf & "2. S355NH" & vbLf & vbLf & "3. S355NLH" & vbLf & vbLf, "Select which option to load")
Select Case Grades
Case 1
Ans = MsgBox("You have selected S355J2H is this correct?", vbYesNo) ' allows a loop if you have made a mistake and will take you back to the selection option
If Ans = vbNo Then GoTo Grade Else:
rng8.Copy: rng7.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
ws.Activate
Columns("BC:BD").Select
With Selection.Font
.ThemeColor = xlThemeColorDark1
.TintAndShade = 0
End With
Case 2
Ans = MsgBox("You have selected S355NH is this correct?", vbYesNo) ' allows a loop if you have made a mistake and will take you back to the selection option
If Ans = vbNo Then GoTo Grade Else:
rng8a.Copy: rng7.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
ws.Activate
Columns("BC:BD").Select
With Selection.Font
.ThemeColor = xlThemeColorDark1
.TintAndShade = 0
End With
Case 3
Ans = MsgBox("You have selected S355NLH is this correct?", vbYesNo) ' allows a loop if you have made a mistake and will take you back to the selection option
If Ans = vbNo Then GoTo Grade Else:
rng8b.Copy: rng7.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
ws.Activate
Columns("BC:BD").Select
With Selection.Font
.ThemeColor = xlThemeColorDark1
.TintAndShade = 0
End With
Case Else ' this is where no input or an alternative input is done, it will exit the subroutine
dummy = MsgBox("wrong input please try again", vbCritical)
Exit Sub
End Select
There is a similar code before this step, which I do NOT want to run and I would ideally like to not repeat this code and others from the target macro's in a separate macro, and call this new macro. When I need to update the information it means updating in multiple places instead one just the one or two maximum.
As BigBen suggested, you need to refactor your code. Copy the below code in a Module
Option Explicit
Public rRng8 As Range, rRng8a As Range, rRng8b As Range
Sub CopyRange(rCopyToRng As Range)
Dim iGrade As Long, iAns As Long, iTryAgain As Long
' Set Default Values
iAns = vbNo
iTryAgain = vbYes
' Loop to copy the correct range
Do While iAns <> vbYes And iTryAgain <> vbNo
' Get grade
iGrade = Application.InputBox("Which Grade chemistry do you wish to load & Check against" & vbLf & vbLf & "1. S355 J2H" & vbLf & vbLf & "2. S355NH" & vbLf & vbLf & "3. S355NLH" & vbLf & vbLf, "Select which option to load", , , , , , 1)
' Case to select the correct range to copy
Select Case iGrade
Case 1
iAns = MsgBox("You have selected S355J2H is this correct?", vbYesNo)
If iAns = vbYes Then CopyRangeHelper rCopyToRng, rRng8
Case 2
iAns = MsgBox("You have selected S355NH is this correct?", vbYesNo)
If iAns = vbYes Then CopyRangeHelper rCopyToRng, rRng8a
Case 3
iAns = MsgBox("You have selected S355NLH is this correct?", vbYesNo)
If iAns = vbYes Then CopyRangeHelper rCopyToRng, rRng8b
Case Else
' If the user entere incorrect number, ask if the want to try again
iTryAgain = MsgBox("Wrong input. Do you want to try again?", vbQuestion + vbYesNo)
End Select
Loop
End Sub
Sub CopyRangeHelper(rCopyToRange As Range, rRngToCopy As Range)
' Copy range
rRngToCopy.Copy: rCopyToRange.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
' Set range format
With rCopyToRange
.Interior.ThemeColor = xlThemeColorDark1
.Interior.TintAndShade = 0
End With
End Sub
NOTE: You don't need to use Select or Activate. You just reference what you need to work with
How to use this:
Below is a sample UDF that calls CopuRange UDF to perform the action
Sub TestThis()
Dim oWS As Worksheet: Set oWS = ThisWorkbook.Worksheets("Sheet3") ' Change sheet reference
Set rRng8 = oWS.Range("A1:A16") ' Set ranges as required
Set rRng8a = oWS.Range("B1:B16")
Set rRng8b = oWS.Range("C1:C16")
CopyRange ThisWorkbook.Worksheets("Sheet4").Range("A1:A16") ' Change sheet reference and range
End Sub
I have a question related to the VBA.
Problem
I have a code to do simple task but i don't what's the reason but sometimes this code works perfectly some time it's not.
Code Explanation
Go to active sheets(un-hidden) sheets in the work book.
Search specific text in the assign column, in this case text is "Sum of Current Activity".
Copy the cell before the text.
Go to Reviewer sheet and find sheet name in the table.
Paste the copied cell as link value next to cell where we have sheet name in the table.
Continue the same process until all active sheets searched
CODE
Sub Sum of_Current_activity()
Dim sht As Worksheet
Sheets("Reviewer Sheet").Select
For Each sht In ActiveWorkbook.Worksheets
If sht.Name <> "Reviewer Sheet" And Left(sht.Name, 1) = 0 Then
On Error Resume Next
sht.Select
f2 = " Total"
£1 = ActiveSheet.Name & f2
Sheets(sht).Select
Columns("J:J").Select
Selection.Find(What:="Sum of Current Activity", _
After:=ActiveCell,_
LookIn:=xlValues,_
LookAt:=xlPart,_
SearchOrder:=xlByRows,_
SearchDirection:=x1Next,_
MatchCase:=False).Activate
ActiveCell.Offset(0, 1).Select
Selection.Copy
Sheets("Reviewer Sheet").Select
Columns("C:C").Select
Selection.Find(What:=f1, _
After:=ActiveCell,_
LookIn:=xlValues,_
LookAt:=xlPart,_
SearchOrder:=xlByRows,_
SearchDirection:=xlNext,_
MatchCase:=False).Activate
ActiveCell.Offset(0, 14).Select
ActiveSheet. Paste Link:=True
Else
End If
Next sht
End Sub
P.S, I have 10 different specific text to search in the 25 sheet. this code sometime works for all 10 texts and sometimes miss the values.
Untested but something like this should work:
Sub Sum of_Current_activity()
Dim sht As Worksheet, c1 As Range, c2 As range
For Each sht In ActiveWorkbook.Worksheets
If sht.Name Like "0*" Then
Set c1 = sht.Columns("J:J").Find(What:="Sum of Current Activity", _
LookIn:=xlValues, LookAt:=xlPart, MatchCase:=False)
Set c2 = Sheets("Reviewer Sheet").Columns("C:C").Find( _
What:= sht.Name & " Total", _
LookIn:=xlValues, LookAt:=xlPart, MatchCase:=False)
If not c1 is nothing and not c2 is nothing then
'edit: create link instead of copy value
c2.offset(0, 14).Formula = _
"='" & c1.parent.Name & "'!" & c1.offset(0,1).Address(true, true)
End if
End If
Next sht
End Sub
just because the task is simple, you could use On Error Resume Next statement and make a direct Value paste between ranges:
Sub main()
Dim sht As Worksheet
On Error Resume Next ' prevent any subsequent 'Find()' method failure fro stopping the code
For Each sht In Worksheets
If Left(sht.Name, 1) = "0" Then _
Sheets("Reviewer Sheet").Columns("C:C").Find( _
What:=sht.Name & " Total", _
LookIn:=xlValues, LookAt:=xlPart, MatchCase:=False).Offset(0, 14).Value = sht.Columns("J:J").Find(What:="Sum of Current Activity", _
LookIn:=xlValues, LookAt:=xlPart, MatchCase:=False).Offset(0, 1).Value
Next
End Sub
I once more stress that On Error Resume Next is here used only because it's a case where you can have a full control of its side effects that can arise from ignoring errors and go on
should you use this snippet in a bigger code, than close the snippet with On Error GoTo 0 statement and resume default error handling before going on with some other code.
I have Sheet1 which is a form with fields where we enter data to be fed in the database (Sheet2).
Ideally, here's what I want it to do:
I want to search a field/record using the form contents in Sheet1, then search for that term on Sheet2. If it doesn't exist on Sheet2, give me a pop up message saying data doesn't exist.
If it does exist in Column A on Sheet2, then select the cell to the right of the result (Column B). Then paste that cell's contents in relevant fields on Sheet1
Then continue until all of the fields on Sheet1 has been searched for on Sheet2.
Here's the code I've been using. It only works for about 5 lines before it comes up with an error. Any help would be greatly appreciated.
I really don't want the MsgBox to pop up at all.
Sub abc()
Do Until IsEmpty(ActiveCell)
Dim MyString As String
MyString = ActiveCell
Sheets("Sheet2").Select
Set RangeObj = Cells.Find(What:=MyString, After:=ActiveCell, _
LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows, _
SearchDirection:=xlNext, MatchCase:=False)
If RangeObj Is Nothing Then MsgBox "Not Found" Else: RangeObj.Select
ActiveCell.Offset(0, 1).Range("A1").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Sheet1").Select
ActiveCell.Offset(0, 1).Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
ActiveCell.Offset(-1, -1).Select
Loop
End Sub
Please let me know what I'm doing wrong.
You were on the right path.. just a few amendments to how you were copying the data.
Option Explicit
Sub sheet2_lookup()
Dim strVal As String
Dim wb As Workbook, ws1 As Worksheet, ws2 As Worksheet, RangeObj As Range
Set wb = ThisWorkbook
Set ws1 = wb.Sheets("Sheet1")
Set ws2 = wb.Sheets("Sheet2")
Cells(1, 1).Activate '' amend this to your starting cell
While ActiveCell.Value2 <> ""
strVal = ActiveCell.Value2
Set RangeObj = ws2.Columns("A").Find(What:=strVal, After:=Cells(1, 1), LookIn:=xlValues)
If RangeObj Is Nothing Then
MsgBox "Not Found"
Else
ActiveCell.Offset(0, 1).Value2 = RangeObj.Offset(0, 1).Value2
End If
ActiveCell.Offset(1, 0).Activate
Wend
End Sub
Let me know how it goes.
I have an Excel tracker that I put an "X" in a cell every month if a certain activity is accomplished.
This "X" correlates to a range of cells on the same sheet.
I want when I click on a command box;
If the cell for January has an "X" copy specific cells on the current page to specific cells on another work sheet.
If the cell for February has an "X" copy some other specific cells on the current page to some other specific cells on the other worksheet.
So on and so forth through December.
I have the following code (which does not work):
Private Sub CommandButton1_Click()
Sheets("MRT").Select
If InStr(1, (Range("L8").Value), "X") > 0 Then
Range("E42:AA42").Select
Selection.Copy
Sheets("Test '12").Select
Cells(3, AP).Select
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone
End If
End Sub
Try this:
Private Sub CommandButton1_Click()
If Sheets("MRT").Range("L8").Value like "*X*" Then
Sheets("MRT").Range("E42:AA42").Copy
Sheets("Test '12").Cells(3, 1).PasteSpecial Paste:=xlValues, Operation:=xlNone
End If
End Sub
Worked in my test, however you might want to adapt Cells(3,1) and the other position specifiers to your desired targets.
edit: forgot about the part with the months ... wait a minute ... here:
Sub FindSignificant()
Dim SearchString As String
Dim SearchRange As Range, cl As Range
Dim FirstFound As String
Dim sh As Worksheet
' Set Search value
SearchString = "a"
Application.FindFormat.Clear
' loop through all sheets
Set sh = Sheets("MRT")
' Find first instance on sheet
Set cl = sh.Cells.Find(What:=SearchString, _
After:=sh.Cells(1, 1), _
LookIn:=xlFormulas, _
LookAt:=xlPart, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False, _
SearchFormat:=False)
If Not cl Is Nothing Then
' if found, remember location
FirstFound = cl.Address
' format found cell
Do
Select Case sh.Cells(cl.Row, 1).Value
Case "december"
sh.Range("E42:AA42").Copy
Sheets("Test '12").Cells(3, 1).PasteSpecial Paste:=xlValues, Operation:=xlNone
Case "february"
sh.Range("E42:AA42").Copy
Sheets("Test '12").Cells(3, 1).PasteSpecial Paste:=xlValues, Operation:=xlNone
Case Else
'do nothing
End Select
' find next instance
Set cl = sh.Cells.FindNext(After:=cl)
' repeat until back where we started
Loop Until FirstFound = cl.Address
End If
End Sub
this code origins from here
You would have to adapt the select case, but i really would think about solving this without VBA, if it is not necessary ;)