Find value based off multiple for loops - excel

I'm trying to take a part number from one sheet, find it in another sheet, then for the cells that correspond to tomorrow's date copy the quantity of parts for that specific part number plus two weeks out which is the resize. The code is starting to get really messy and I'm getting confused as to why it's not working. Currently I'm getting an error on cilrow = cil.rows with a mismatch.
Dim cel As Range
Dim cul As Range
Dim cil As Range
Dim cilrow As Long
Dim culcol As Long
Dim wkbOrig As Workbook
Dim wkbShape As Workbook
Dim shtShape As Worksheet
Set wkbOrig = ThisWorkbook
Set wkbShape = Workbooks("SHAPE Detailed coverage tracking WK" & WorksheetFunction.IsoWeekNum(Date))
Set shtShape = wkbShape.Worksheets("Detail coverage tracking")
For Each cel In wkbOrig.Sheets(2).Range("C3:C4,C9:C14")
For Each cil In shtShape.Range("H6:H11")
If Left(cel, 10) = cil.Value Then
cilrow = cil.Rows
For Each cul In shtShape.Range("5:5")
If cul.Value = Date + 1 Then
culcol = cul.Column
Range(Cells(cilrow, culcol)).Resize(, 14).Copy
End If
Next
End If
Next
Next

You can do less looping if you use Match().
Untested:
Sub Tester()
Dim cel As Range, wkbShape As Workbook, shtShape As Worksheet
Dim wkbOrig As Workbook, dateCol As Variant, matchRow As Variant
Dim rngSrch As Range
Set wkbOrig = ThisWorkbook
'best to include the file extension in the workbook name...
Set wkbShape = Workbooks("SHAPE Detailed coverage tracking WK" & _
WorksheetFunction.IsoWeekNum(Date))
Set shtShape = wkbShape.Worksheets("Detail coverage tracking")
'try to match the date...
dateCol = Application.Match(CLng(Date + 1), shtShape.Rows(5), 0)
If IsError(dateCol) Then 'date not matched?
MsgBox "Tomorrow's date not found on Row6 of " & shtShape.Name, vbExclamation
Exit Sub
End If
Set rngSrch = shtShape.Range("H6:H11")
For Each cel In wkbOrig.Sheets(2).Range("C3:C4,C9:C14").Cells
matchRow = Application.Match(Left(cel.Value, 10), rngSrch, 0)
If Not IsError(matchRow) Then
rngSrch.Cells(matchRow).EntireRow.Cells(dateCol).Resize(1, 14).Copy 'to where ?
End If
Next
End Sub

Related

Commenting on cells

So I have some code that comments on cells based on information beside of it and it is working almost flawlessly. However, I am having an issue where it is working on all sheets in the entire workbook instead of just sheet 3 like it is supposed to. I have this code set up on sheet 3 only in the VBA projects. So my question is how would I make this work only on one single sheet?
Here is my code
Private Sub Worksheet_Calculate()
ActiveSheet.UsedRange.ClearComments
Dim targetRng As Range, commentSrcRng As Range
Dim strPrefix As String 'string Prefix
Set targetRng = Application.Range("D16,D18,D20,D22,D24,D26,D28,D30,D32,D34,D36,D38")
Set commentSrcRng = targetRng.Offset(0, 1)
Dim cel As Range
Dim i As Long
i = 1
For Each cel In targetRng
If cel <> "" Then
cel.AddComment
cel.Comment.Visible = False
cel.Comment.Shape.TextFrame.AutoSize = True
cel.Comment.Text strPrefix & commentSrcRng.Cells(i)
End If
i = i + 2
Next
However, I am having an issue where it is working on all sheets in the entire workbook
That's because you've coded it to work on the ActiveSheet
To refer to the sheet the event is coded in, use Me
Private Sub Worksheet_Calculate()
Me.UsedRange.ClearComments
Dim targetRng As Range, commentSrcRng As Range
Dim strPrefix As String 'string Prefix
Set targetRng = Me.Range("D16,D18,D20,D22,D24,D26,D28,D30,D32,D34,D36,D38")
Set commentSrcRng = targetRng.Offset(0, 1)
Dim cel As Range
Dim i As Long
i = 1
For Each cel In targetRng
If cel <> "" Then
cel.AddComment
cel.Comment.Visible = False cel.Comment.Shape.TextFrame.AutoSize = True
cel.Comment.Text strPrefix & commentSrcRng.Cells(i)
End If
i = i + 2
Next
End Sub

Script to Copy and paste entirerows and mergedrows?

The following code is the one that I'm trying to work with, but I still can't make it work with merge rows. The main idea is to create a loop to check each row from D1:D150 and if the criteria are met then copy the entire row.
This is how my data looks like
Sub attributes()
'--------------------------------------------------------------------
Dim Cel, aCell1, aCell2, aCell3, aCellAsses As Range, ws, ws0 As Worksheet
Dim strAsses1 As Boolean
Dim num As Integer
'------------------------------
Set ws = ActiveWorkbook.Sheets("Contract Attributes")
Set ws0 = ActiveWorkbook.Sheets("ReviewerTab")
ws.Activate
Set aCell1 = ActiveWorkbook.Sheets("Contract Attributes").Range("A1:A150")
'Set aCell1 = ActiveWorkbook.Sheets("Contract Attributes").Range("D1:D150")
'Set aCell2 = ActiveWorkbook.Sheets("Contract Attributes").Range("D:D").Find("Current Modifications", LookIn:=xlValues)
'--------------------------------------------------------------------
strName1 = InputBox("Which contract modification would you like to review?")
num = 5
For Each Cel In aCell1
If InStr(1, Cel, strName1, vbTextCompare) > 0 Or InStr(1, Cel, "x") > 0 Then
Cel.MergeArea.Select
Selection.EntireRow.Copy
ws0.Activate
Rows(num).Insert
ws.Activate
num = num + 1
End If
Next Cel
'--------------------------------------------------------------------
'ws0.Columns(4).Delete
'aCell2.Select
'ActiveCell.EntireRow.Copy
'Sheets("ReviewerTab").Range("A5").Insert
End Sub
TIPS
To begin with, I would recommend that you see How to avoid using Select in Excel VBA. Next you need to identify the range object that you need to copy and then copy them across.
Dim Cel, aCell1, aCell2, aCell3, aCellAsses As Range You need to declare them explicitly else the first four objects are declared as Variant and not Range. For example Dim Cel As Range, aCell1 As Range, aCell2 As Range, aCell3 As Range, aCellAsses As Range
Do not copy the rows in a loop. It will be slow. Identify the rows you want to copy and then copy them in one go. Below is an example
SAMPLE SCENARIO
To demonstrate how this works, I am taking the below sample.
CODE
I have come up with a basic code. I have commented it so you should not have a problem understanding it. But if you do then feel free to ask :).
Option Explicit
Sub Sample()
Dim wsInput As Worksheet
Dim wsOuput As Worksheet
Dim RangeToCopy As Range
Dim lRow As Long, i As Long, num As Long
Dim searchText As Variant
'~~> Row in output sheet where the rows will be copied
num = 5
'~~> Set your input and output sheets
Set wsInput = ThisWorkbook.Sheets("Contract Attributes")
Set wsOuput = ThisWorkbook.Sheets("ReviewerTab")
'~~> Take the input from the user
searchText = InputBox("Which contract modification would you like to review?")
If Len(Trim(searchText)) = 0 Then Exit Sub
With wsInput
lRow = .Range("A" & .Rows.Count).End(xlUp).Row
'~~> Loop through the cells and check for criteria
For i = 1 To lRow
If InStr(1, .Range("A" & i).Value2, searchText, vbTextCompare) Then
'~~> identify the rows you need to copy and store them
'~~> in a range object
If RangeToCopy Is Nothing Then
Set RangeToCopy = .Range("A" & i).MergeArea.EntireRow
Else
Set RangeToCopy = Union(RangeToCopy, .Range("A" & i).MergeArea.EntireRow)
End If
End If
Next i
End With
'~~> Copy them across. You can insert them as well
If Not RangeToCopy Is Nothing Then
RangeToCopy.Copy wsOuput.Rows(num)
End If
End Sub
IN ACTION
You need to include the merge area before "Select".
After you copy the rows, you need to count how many merged rows in the copy. I add a new variable num2 to do so. The loop cannot just simply num=num+1, it varies from what rows copied.
You may try the below code.
Sub attributes()
'--------------------------------------------------------------------
Dim Cel, aCell1, aCell2, aCell3, aCellAsses As Range, ws, ws0 As Worksheet
Dim strAsses1 As Boolean
Dim num As Integer
Dim num2 As Integer
Set ws = ActiveWorkbook.Sheets("Contract Attributes")
Set ws0 = ActiveWorkbook.Sheets("ReviewerTab")
ws.Activate
Set aCell1 = ActiveWorkbook.Sheets("Contract Attributes").Range("A1:A150")
strName1 = InputBox("Which contract modification would you like to review?")
num = 5
For Each Cel In aCell1
If InStr(1, Cel, strName1, vbTextCompare) > 0 Or InStr(1, Cel, "x") > 0 Then
Range(Cells(Cel.Row, 1), Cells(Cel.Row, Cells(Cel.Row, Columns.Count).End(xlToLeft).Column)).Select
num2 = Selection.Rows.Count
Selection.EntireRow.Copy
ws0.Activate
Rows(num).Insert
ws.Activate
num = num + num2
End If
Next Cel
End Sub

Loop through Excel Sheet

I'm working with two workbooks. In the first I search for the value in the cell to the right of "Charge Number". Take that value and search the second workbooks pivot table for the matching row, copy it and go back to first work book and paste the data. This works great once. But I'm unable to get a loop to look for the next instance of "Charge Number" and repeat the process. The loop I have in the code isn't right because it finds the first value fine but then searches every next row for the same Charge Number.
Sub FindChargeNo()
Dim Loc As Range
Dim ChgNum As String
Dim SrchRng2 As String
Dim pvt As PivotTable
Dim wb As Workbook, ws As Worksheet
Dim FstWB As Workbook
Dim SecWB As Workbook
Dim rng As Range
Set FstWB = Workbooks("First.xlsm")
Set SecWB = Workbooks("Second_test.xlsx")
Set ws1 = FstWB.Worksheets("New Development")
Set ws = SecWB.Worksheets("Aug 18 Report")
Set pvt = ws.PivotTables(1)
lastRow = FstWB.Worksheets("New Development").Range("J" & Rows.Count).End(xlUp).Row
For i = 1 To lastRow
Set Loc = ws1.Cells.Find(What:="Charge Number")
If Not Loc Is Nothing Then
ChgNum = Loc.Offset(0, 1).Value
Debug.Print ChgNum
Debug.Print SrchRng
With pvt.PivotFields("Project WBS").PivotItems(ChgNum).LabelRange
Set rng = ws.Range(.Resize(.Rows.Count, pvt.TableRange1.Columns.Count).Address)
ws.Range(rng.Address).Copy
End With
SrchRng2 = Loc.Offset(0, 5).Address
FstWB.Worksheets("New Development").Range(SrchRng2).PasteSpecial
Set Loc = ws1.Cells.FindNext(Loc)
Loop While Loc.Address <> firstAddress
End If
Next
End Sub

VBA in Excel: Runtime Error 1004

I am trying to do the following. I have several spreadsheets that are named something like "ITT_198763" where the ITT part stays the same but the number changes. I also have one tab called program where the 6 digit number is imported on row 40 (hence the RngToSearch below). I need the program to 1) find the "ITT" sheet for a certain 6 digit number, 2) identify the corresponding row in the "Program" tab, and copy information from the "ITT" tab to row 41 of the identified column. I will be copying more information from the ITT sheet to the specified column, but for now I am just trying to get it to work once.
From the MsgBox, I know it identifies the correct prjNumber (the 6 digit number), but I get the runtime 1004 error on the line Set RngDest. Any help will be appreciated!
Sub Summary_Table()
Dim wks As Worksheet
Dim RngToSearch As Range, RngDest As Range
Dim foundColumn As Variant
Dim prjNumber
For Each wks In ActiveWorkbook.Worksheets
If ((Left(wks.Name, 3) = "ITT")) Then
prjNumber = Right(wks.Name, 6)
MsgBox (prjNumber)
Set RngToSearch = Sheets("Program").Range("C40:q40")
foundColumn = Sheets("Program").Application.Match(prjNumber, RngToSearch, False)
With Sheets("Program")
Set RngDest = .Range(1, foundColumn) 'Project Name
End With
If Not IsError(foundColumn) Then
wks.Range("E2").Copy RngDest
End If
End If
Next wks
End Sub
I tried the .cell instead with the following code (all else is the same) and now get runtime error 13 on the Set RngDest line:
Set RngToSearch = Sheets("Program").Range("C40:q48")
foundColumn = Sheets("Program").Application.Match(prjNumber, RngToSearch.Rows(1), False)
With Sheets("Program")
Set RngDest = RngToSearch.Cells(1, foundColumn) 'Project Name
End With
Yuo are getting that error because foundColumn has an invalid value. Step through the code and see what is the value of foundColumn
Here is an example which works.
Sub Sample()
Dim RngDest As Range, RngToSearch As Range
foundColumn = 1
Set RngToSearch = Sheets("Program").Range("C40:q40")
Set RngDest = RngToSearch.Cells(1, foundColumn)
Debug.Print RngDest.Address
End Sub
Add MsgBox foundColumn before the line Set RngDest = RngToSearch.Cells(1, foundColumn) and see what value do you get. I guess the line
foundColumn = Sheets("Program").Application.Match(prjNumber, RngToSearch, False)
is not giving you the desired value. Here is the way to reproduce the error.
EDIT (Solution)
You need to handle the situation when no match is found. Try something like this
Sub Sample()
Dim RngDest As Range, RngToSearch As Range
Set RngToSearch = Sheets("Program").Range("C40:q40")
foundcolumn = Sheets("Program").Application.Match(1, RngToSearch, False)
If CVErr(foundcolumn) = CVErr(2042) Then
MsgBox "Match Not Found"
Else
Set RngDest = RngToSearch.Cells(1, foundcolumn)
'
'~~> Rest of the code
'
End If
End Sub
You are looking for the Cells function, which has the prototype .Cells([RowIndex], [ColumnIndex]). The Range function takes either a string with a range name (like "A1", or a named range), or other range references.
I figured it out! Found column was the problem. Combining that with the help from the other commenters, the following works:
Sub Summary_Table()
Dim wks As Worksheet
Dim RngToSearch As Range, RngDest As Range
Dim foundColumn As Variant
Dim prjNumber
For Each wks In ActiveWorkbook.Worksheets
If ((Left(wks.Name, 3) = "ITT")) Then
prjNumber = Right(wks.Name, 6)
MsgBox (prjNumber)
Set RngToSearch = Sheets("Program").Range("a40:q48")
foundColumn = Sheets("Program").Rows(40).Find(what:=prjNumber, LookIn:=xlValues, lookat:=xlWhole, MatchCase:=False).Column
MsgBox (foundColumn)
With Sheets("Program")
Set RngDest = RngToSearch.Cells(2, foundColumn) 'Project Name
Debug.Print RngDest.Address
End With
If Not IsError(foundColumn) Then
wks.Range("E3").Copy RngDest
End If
End If
Next wks
End Sub

Getting type mismatch error when setting Worksheet.Name to a cell.value in VBA

I have written the following code to create worksheet with names same as the names in first column of Sheet1
I am getting a TypeError when trying to set the name on the new worksheet but don't know why. Can someone help?
Sub CreateWorkSheets()
'
' Macro5 Macro
'
'
Dim r As Range
Set r = Sheets("Sheet1").Columns(1)
For Each cell In r
Dim aa As String
Dim newSheet As Worksheet
Set newSheet = Sheets.Add(After:=Sheets(Sheets.Count))
strTemp = cell.Value
newSheet.Name = strTemp // Error Here
Next cell
End Sub
I tried the following code as well and that doesn't work either even though strValue is valid
Sub Test1()
Sheets("Sheet1").Select
Dim x As Integer
' Set numrows = number of rows of data.
NumRows = Range("A2", Range("A2").End(xlDown)).rows.Count
' Select cell a1.
Range("A2").Select
' Establish "For" loop to loop "numrows" number of times.
For x = 1 To NumRows
Dim newSheet As Worksheet
Set newSheet = Sheets.Add(After:=Sheets(Sheets.Count))
Sheets("Sheet1").Range("B1").Value = "A" + Trim(Str(x))
strValue = "A" + Trim(Str(x))
newSheet.Name = Str(Sheets("Sheet1").Range(strValue).Value)
Next
End Sub
Apparently because you set:
Set r = Sheets("Sheet1").Columns(1)
It set the cell object to column $A:$A instead of $A$1 like you would think. I put this in the immediate window when I ran into the "cell.value" line:
?cell.Address
$A:$A
You should avoid using an entire column to do what you're trying to do and I would highly recommend you add these keywords to the top of your module:
Option Explicit
This will check your code a little more thoroughly and help you avoid unwanted errors.
To fix this, you can get the exact range you need and I recommend you declare every variable so it stays a specific type.
Something like this:
Option Explicit
Sub CreateWorkSheets()
Dim r As Range
Dim sh As Worksheet
Dim tempSh As Worksheet
Dim cell As Range
Dim strTemp As String
Set sh = Sheets("Sheet1")
Set r = sh.Range(sh.Cells(1, 1), sh.Cells(sh.Rows.Count, 1).End(xlUp))
For Each cell In r
Set tempSh = Sheets.Add(After:=Sheets(Sheets.Count))
strTemp = cell.Value
tempSh.Name = strTemp '// no more error
Next cell
End Sub

Resources