i m trying to loop through project components and if the result is 3 (Userform) to loop through teach Userform and get it's control name and properties but i receive an error in the second for each.
any help will appreciate!!
Option Explicit
Sub Find_From_control()
Dim Control As Control
Dim Component As Object
Dim LastRow As Long
For Each Component In ThisWorkbook.VBProject.VBComponents
If Component.Type = 3 Then
For Each Control In Form.Controls
LastRow = wsControl.Range("I" & Rows.Count).End(xlUp).Row
If TypeName(Control) = "TabStrip" Or TypeName(Control) = "ScrollBar" Or TypeName(Control) = "SpinButton" Or TypeName(Control) = "MultiPage" Or TypeName(Control) = "TextBox" Then
wsControl.Range("I" & LastRow + 1).Value = Control.Name
wsControl.Range("J" & LastRow + 1).Value = Control.Type
wsControl.Range("L" & LastRow + 1).Value = Control.Tag
wsControl.Range("M" & LastRow + 1).Value = Control.TabIndex
ElseIf TypeName(Control) = "Image" Then
wsControl.Range("I" & LastRow + 1).Value = Control.Name
wsControl.Range("J" & LastRow + 1).Value = Control.Type
wsControl.Range("L" & LastRow + 1).Value = Control.Tag
ElseIf TypeName(Control) = "Frame" Or TypeName(Control) = "ToggleButton" Or TypeName(Control) = "OptionButton" Or TypeName(Control) = "CheckBox" Or TypeName(Control) = "Label" Or TypeName(Control) = "CommandButton" Then
wsControl.Range("I" & LastRow + 1).Value = Control.Name
wsControl.Range("J" & LastRow + 1).Value = Control.Type
wsControl.Range("K" & LastRow + 1).Value = Control.Caption
wsControl.Range("L" & LastRow + 1).Value = Control.Tag
wsControl.Range("M" & LastRow + 1).Value = Control.TabIndex
ElseIf TypeName(Control) = "ListBox" Or TypeName(Control) = "ComboBox" Then
wsControl.Range("I" & LastRow + 1).Value = Control.Name
wsControl.Range("J" & LastRow + 1).Value = Control.Type
wsControl.Range("L" & LastRow + 1).Value = Control.Tag
wsControl.Range("M" & LastRow + 1).Value = Control.TabIndex
wsControl.Range("N" & LastRow + 1).Value = Control.ColumnCount
End If
Next
End If
Next
End Sub
The Userform is the Component Component.Designer.
Control.Type is not a valid property, use TypeName(Control) instead.
Sub Find_From_control()
Dim Control As Control
Dim Component As Object
Dim Form As UserForm
Dim LastRow As Long
For Each Component In ThisWorkbook.VBProject.VBComponents
If Component.Type = 3 Then
Set Form = Component.Designer
For Each Control In Form.Controls
LastRow = wsControl.Range("I" & Rows.count).End(xlUp).Row
If TypeName(Control) = "TabStrip" Or TypeName(Control) = "ScrollBar" Or TypeName(Control) = "SpinButton" Or TypeName(Control) = "MultiPage" Or TypeName(Control) = "TextBox" Then
wsControl.Range("I" & LastRow + 1).Value = Control.Name
wsControl.Range("J" & LastRow + 1).Value = TypeName(Control)
wsControl.Range("L" & LastRow + 1).Value = Control.Tag
wsControl.Range("M" & LastRow + 1).Value = Control.TabIndex
ElseIf TypeName(Control) = "Image" Then
wsControl.Range("I" & LastRow + 1).Value = Control.Name
wsControl.Range("J" & LastRow + 1).Value = TypeName(Control)
wsControl.Range("L" & LastRow + 1).Value = Control.Tag
ElseIf TypeName(Control) = "Frame" Or TypeName(Control) = "ToggleButton" Or TypeName(Control) = "OptionButton" Or TypeName(Control) = "CheckBox" Or TypeName(Control) = "Label" Or TypeName(Control) = "CommandButton" Then
wsControl.Range("I" & LastRow + 1).Value = Control.Name
wsControl.Range("J" & LastRow + 1).Value = TypeName(Control)
wsControl.Range("K" & LastRow + 1).Value = Control.Caption
wsControl.Range("L" & LastRow + 1).Value = Control.Tag
wsControl.Range("M" & LastRow + 1).Value = Control.TabIndex
ElseIf TypeName(Control) = "ListBox" Or TypeName(Control) = "ComboBox" Then
wsControl.Range("I" & LastRow + 1).Value = Control.Name
wsControl.Range("J" & LastRow + 1).Value = TypeName(Control)
wsControl.Range("L" & LastRow + 1).Value = Control.Tag
wsControl.Range("M" & LastRow + 1).Value = Control.TabIndex
wsControl.Range("N" & LastRow + 1).Value = Control.ColumnCount
End If
Next
End If
Next
End Sub
Related
I would like to somehow get the value from the different controls on the user form and then write them on the sheet after that if the user form is closed down and re opened if a name is selected in the combobox then load all data in the form back ready to change values. I have 13 rows that a user can use on the user form.
In my code the writing the data to the sheet will write all item selected i want but it takes too long because all of the loops and ifs. Is there a better way to achieve what i want?
Private Sub FillingInForm()
Dim i As Long
Dim WS As Worksheet
Dim ctl As MSForms.Control
Dim lbl As MSForms.Label
Dim cmb As MSForms.ComboBox
Dim txtbox As MSForms.TextBox
Dim optbtn As MSForms.OptionButton
Set WS = ActiveSheet
With WS
For i = 1 To ItemsListFrame.Controls.Count
For Each ctl In ItemsListFrame.Controls
If TypeName(ctl) = "Label" Then
If ctl.Tag = "GroupItem" & i Then
Set lbl = ctl
If Controls("Item" & i).Value <> vbNullString Then
.Range("A" & i + 6).Offset(0, 0).Value = Me.OrderNo.Value
.Range("A" & i + 6).Offset(0, 1).Value = Me.NextCollectionDate.Text
.Range("A" & i + 6).Offset(0, 1).Value = Format(.Range("A" & i + 6).Offset(0, 1).Value, "dd/mm/yyyy")
.Range("A" & i + 6).Offset(0, 8).Value = Me.DateReturnBy.Value
.Range("A" & i + 6).Offset(0, 8).Value = Format(.Range("A" & i + 6).Offset(0, 8).Value, "dd/mm/yyyy")
Controls("OrderLbl" & i).Enabled = True
End If
End If
ElseIf TypeName(ctl) = "ComboBox" Then
If ctl.Tag = "GroupItem" & i Then
Set cmb = ctl
If Controls("Item" & i).Value <> vbNullString Then
Controls("Item" & i).Enabled = True
End If
If Controls("Item" & i).Value <> vbNullString Then
.Range("A" & i + 6).Offset(0, 2).Value = Controls("Item" & i).Text
End If
End If
ElseIf TypeName(ctl) = "TextBox" Then
If ctl.Tag = "GroupItem" & i Then
Set txtbox = ctl
If Controls("Item" & i).Value <> vbNullString Then
.Range("A" & i + 6).Offset(0, 3).Value = Controls("Qty" & i).Value
.Range("A" & i + 6).Offset(0, 4).Value = Controls("UnitPrice" & i).Value
.Range("A" & i + 6).Offset(0, 5).Value = Controls("SubTotal" & i).Value
.Range("A" & i + 6).Offset(0, 7).Value = Controls("Comments" & i).Value
Controls("Qty" & i).Enabled = True
Controls("UnitPrice" & i).Enabled = True
Controls("SubTotal" & i).Enabled = True
Controls("Comments" & i).Enabled = True
End If
End If
ElseIf TypeName(ctl) = "OptionButton" Then
If ctl.Tag = "GroupItem" & i Or ctl.Tag = "InOut" & i Then
Set optbtn = ctl
If Controls("Item" & i).Value <> vbNullString Then
.Range("A" & i + 6).Offset(0, 6).Value = Controls("OptionOut" & i).Value
Controls("OptionIn" & i).Enabled = True
Controls("OptionOut" & i).Enabled = True
End If
End If
End If
Next ctl
Next i
End With
End Sub
I had created a Macro that reads data from a sheet and create journal entries. I had to update the macro due to some changes to the spreadsheet however now my macro doesnt work.
My macro works if I step through the entire thing or if I hit the play button in the VSB screen. However If I hit the macro button I embedded in spreadsheet, it breaks. I believe its breaking because its skipping this section:
If Cells(iRow2, 1) = "CCC $" Then
wsUp.Cells(iRow2, 1).Value = "CC"
ElseIf Cells(iRow2, 1) = "DDD $" Then
I am not sure why it is skipping this only when I bit the embedded button and not when I run it from the VSB screen.
Sub CreateAllocations_JEs()
Dim iRow As Integer, iCol As Integer, iRow2 As Integer
Dim sEntity As String, sEnt2 As String, sVal1 As String, sEnt3 As String, sDesc2 As String
Dim wsEntry As Worksheet
Dim wsUp As Worksheet
Dim wsInst As Worksheet
Set wsInst = Worksheets("Instructions")
Set wsEntry = Worksheets("Entries")
Set wsUp = Worksheets("Sheet1")
Dim lastrow As Long
Dim sRange As Range
Dim sQLNE As Long
''' Creates expense for holdings
For iRow = 6 To 35
lastrow = wsUp.Cells(Rows.Count, "A").End(xlUp).Row
sEntity = wsEntry.Range("D5").Value
sAcct = wsEntry.Range("N" & iRow).Value
sAcct2 = wsEntry.Range("M" & iRow).Value
sDesc = wsEntry.Range("O" & iRow).Value
vsum = Application.WorksheetFunction.Sum(wsEntry.Range("E" & iRow & ":J" & iRow))
If vsum > 0 Then
wsUp.Range("A" & lastrow + 1).Value = sEntity
wsUp.Range("J" & lastrow + 1).Value = vsum
wsUp.Range("G" & lastrow + 1).Value = sAcct
''''' Adds description column using the companies that have payables
sDesc2 = ""
End If
For iCol = 5 To 12
If wsEntry.Cells(iRow, iCol) > 0 Then
sEnt3 = wsEntry.Cells(5, iCol).Value
If sDesc2 <> "" Then
sDesc2 = sDesc2 & ", "
End If
sDesc2 = sDesc2 & sEnt3
End If
Next iCol
wsUp.Range("M" & lastrow + 1).Value = sDesc & sDesc2
'''''' Creates receivable for holdings and related fields
For iCol = 5 To 10
If wsEntry.Cells(iRow, iCol) > "0" Then
sVal1 = wsEntry.Cells(iRow, iCol).Value
sDesc = wsEntry.Range("O" & iRow).Value
sEnt3 = wsEntry.Cells(5, iCol).Value
lastrow = wsUp.Cells(Rows.Count, "A").End(xlUp).Row
wsUp.Range("A" & lastrow + 1).Value = sEntity
wsUp.Range("I" & lastrow + 1).Value = sVal1
vRec = Application.WorksheetFunction.Index(Sheets("IC accounts").Range("C:C"), Application.WorksheetFunction.Match(Sheets("Entries").Cells(5, iCol), Sheets("IC accounts").Range("B:B"), 0), 1)
wsUp.Range("G" & lastrow + 1).Value = vRec
wsUp.Range("M" & lastrow + 1).Value = sDesc & sEnt3
End If
Next iCol
''''Creates the payables and expense in other companies
For iCol = 5 To 12
If wsEntry.Cells(iRow, iCol) > "0" Then
sEnt2 = wsEntry.Cells(5, iCol).Value
sval2 = wsEntry.Cells(iRow, iCol).Value
lastrow = wsUp.Cells(Rows.Count, "A").End(xlUp).Row
wsUp.Range("A" & lastrow + 1, "A" & lastrow + 2).Value = sEnt2
If wsUp.Range("A" & lastrow + 1).Value = "AAA $" Then
wsUp.Range("J" & lastrow + 1).Value = sval2
wsUp.Range("I" & lastrow + 2).Value = sval2
wsUp.Range("G" & lastrow + 1).Value = sAcct2
wsUp.Range("G" & lastrow + 2).Value = "00-1320001"
ElseIf wsUp.Range("A" & lastrow + 1).Value = "BBB $" Then
wsUp.Range("J" & lastrow + 1).Value = sval2
wsUp.Range("I" & lastrow + 2).Value = sval2
wsUp.Range("G" & lastrow + 1).Value = sAcct2
wsUp.Range("G" & lastrow + 2).Value = "00-1320002"
Else
wsUp.Range("I" & lastrow + 1).Value = sval2
wsUp.Range("J" & lastrow + 2).Value = sval2
wsUp.Range("G" & lastrow + 1).Value = sAcct2
wsUp.Range("G" & lastrow + 2).Value = "00-4100040"
End If
wsUp.Range("M" & lastrow + 1, "M" & lastrow + 2).Value = sDesc & sEntity
End If
Next iCol
Next iRow
lastrow = wsUp.Cells(Rows.Count, "A").End(xlUp).Row
For iRow2 = 2 To lastrow
If Cells(iRow2, 1) = "CCC $" Then
wsUp.Cells(iRow2, 1).Value = "CC"
ElseIf Cells(iRow2, 1) = "DDD $" Then
wsUp.Cells(iRow2, 1).Value = "DD"
ElseIf Cells(iRow2, 1) = "EEE $" Then
wsUp.Cells(iRow2, 1).Value = "EE"
ElseIf Cells(iRow2, 1) = "FFF $" Then
wsUp.Cells(iRow2, 1).Value = "FF"
ElseIf Cells(iRow2, 1) = "GGG $" Then
wsUp.Cells(iRow2, 1).Value = "GG"
ElseIf Cells(iRow2, 1) = "HHH $" Then
wsUp.Cells(iRow2, 1).Value = "LLL"
ElseIf Cells(iRow2, 1) = "AAA $" Then
wsUp.Cells(iRow2, 1).Value = "LLL"
ElseIf Cells(iRow2, 1) = "LLL $" Then
wsUp.Cells(iRow2, 1).Value = "LLL"
ElseIf Cells(iRow2, 1) = "JJJ $" Then
wsUp.Cells(iRow2, 1).Value = "JJ"
End If
wsUp.Activate
Code Breaks Here. I beleive because skips section above.
vCN =
Application.WorksheetFunction.Index(Sheets("Company").Range("B:B"),
Application.WorksheetFunction.Match(Sheets("Sheet1").Cells(iRow2, 1),
Sheets("Company").Range("A:A"), 0), 1)
wsUp.Range("B" & iRow2).Value = vCN
vAN = Application.WorksheetFunction.Index(Sheets("COA").Range("B:B"),
Application.WorksheetFunction.Match(Sheets("Sheet1").Cells(iRow2, 7),
Sheets("COA").Range("A:A"), 0), 1)
wsUp.Range("H" & iRow2).Value = vAN
sQLNE = wsUp.Cells(Rows.Count, "N").End(xlUp).Row
wsUp.Range("N" & iRow2).Value = sQLNE
wsUp.Range("S" & iRow2).Value = wsUp.Range("I" & iRow2).Value
wsUp.Range("T" & iRow2).Value = wsUp.Range("J" & iRow2).Value
Next iRow2
lastrow = wsUp.Cells(Rows.Count, "A").End(xlUp).Row
sBatch = wsInst.Cells(8, 2).Value
sMonth = wsInst.Cells(6, 2).Value
sYear = wsInst.Cells(7, 2).Value
sDate = wsInst.Cells(5, 2).Value
sRef = sBatch & sMonth & sYear
wsUp.Range("C2", "C" & lastrow).Value = sRef
wsUp.Range("f2", "F" & lastrow).Value = sRef
wsUp.Range("D2", "D" & lastrow).Value = "1"
wsUp.Range("e2", "E" & lastrow).Value = "0"
wsUp.Range("K2", "k" & lastrow).Value = sDate
wsUp.Range("I:J").NumberFormat = "0.00"
wsUp.Range("S:T").NumberFormat = "0.00"
For iRow2 = 2 To lastrow
If Cells(iRow2, 9) = "" Then
wsUp.Cells(iRow2, 9).Value = "0.00"
wsUp.Cells(iRow2, 19).Value = "0.00"
ElseIf Cells(iRow2, 10) = "" Then
wsUp.Cells(iRow2, 10).Value = "0.00"
wsUp.Cells(iRow2, 20).Value = "0.00"
End If
Next iRow2
wsInst.Activate
End Sub
The code skips your if block because the parent for the cell has not been mentioned so it uses the activesheet, you have to explicitly mention that so instead of
If Cells(iRow2, 1) = "CCC $" Then
by this line:
MySheet.Cells(iRow2, 1) = "CCC $" Then
I don't know which one of the sheets is MySheet in your code, so replace it yourself
I get
"Type Mismatch" error
I have the following code that loops through two sheets, matching data and fills out column "C" and "D" accordingly. The code works perfectly up until I put in the "And" statements, at which point I get a "Type mismatch" error, and the debugging highlights that line too. I cannot figure out what is wrong, any help would be appreciated.
Sub ind_access_report()
Dim lastrow As Variant
Dim sh1 As Worksheet
Dim sh2 As Worksheet
Dim x As Variant
Dim iName As String
Set sh1 = ActiveWorkbook.Sheets("Sheet1")
Set sh2 = ActiveWorkbook.Sheets("Sheet2")
iName = sh2.Range("A2").Value
lastrow = sh1.Cells(Rows.Count, "A").End(xlUp).Row
For x = 2 To lastrow
If sh1.Range("C" & x).Value = iName _
Then sh2.Range("C" & x + 3).Value = sh1.Range("A" & x).Value _
And sh2.Range("D" & x + 3) = "OWNER"
If sh1.Range("D" & x).Value = iName _
Then sh2.Range("C" & x + 3).Value = sh1.Range("A" & x).Value _
And sh2.Range("D" & x + 3) = "BACKUP"
If sh1.Range("E" & x).Value = iName _
Then sh2.Range("C" & x + 3).Value = sh1.Range("A" & x).Value _
And sh2.Range("D" & x + 3) = "BACKUP"
Next x
You will have to rethink your line break strategy. It is the main reason of why it is failing. If you have a line break after Then, you will need an End If.
Try this:
Sub ind_access_report()
Dim lastrow As Variant
Dim sh1 As Worksheet
Dim sh2 As Worksheet
Dim x As Variant
Dim iName As String
Set sh1 = ActiveWorkbook.Sheets("Sheet1")
Set sh2 = ActiveWorkbook.Sheets("Sheet2")
iName = sh2.Range("A2").Value
lastrow = sh1.Cells(Rows.Count, "A").End(xlUp).Row
For x = 2 To lastrow
If sh1.Range("C" & x).Value = iName Then
sh2.Range("C" & x + 3).Value = sh1.Range("A" & x).Value
sh2.Range("D" & x + 3) = "OWNER"
End If
If sh1.Range("D" & x).Value = iName Then
sh2.Range("C" & x + 3).Value = sh1.Range("A" & x).Value
sh2.Range("D" & x + 3) = "BACKUP"
End If
If sh1.Range("E" & x).Value = iName Then
sh2.Range("C" & x + 3).Value = sh1.Range("A" & x).Value
sh2.Range("D" & x + 3) = "BACKUP"
End If
Next x
End If
You are not using And correctly. You are probably trying to do multiple things in your If statement. Using And is not how you do it. Instead, use multiple lines and End If like this:
If sh1.Range("C" & x).Value = iName Then
sh2.Range("C" & x + 3).Value = sh1.Range("A" & x).Value
sh2.Range("D" & x + 3) = "OWNER"
End If
With help from many helpful people on here I have got to the point where the code does exactly what I need it to do!
I am really struggling with the MsgBox at the end that display how many rows have been copied to each sheet. I would also like it to display if there were any non-matches from the Global sheet in the same MsgBox. If no non-matches were found then this part can be omitted.
Below is the code i have that searches the sheet for the values in column Q and the finds the match in the ComboBox2 on the UserForm. This tells what sheet the rows need to be copied to, and if a new sheet is needed then also what to name it along with some other needed information.
Private Sub CommandButton1_Click()
Dim i As Long, j As Long, k As Long, strWS As String, rngCPY As Range
Dim noFind As Variant: noFind = UserForm2.ComboBox2.List '<~~~ get missed items
With Application: .ScreenUpdating = False: .EnableEvents = False: .CutCopyMode = False: End With
If Range("L9") = "" Then: MsgBox "You can't Split the Jobs at this stage. " & vbLf & vbLf & "Please create the form for the Sub-Contractor First." & vbLf & vbLf & "Please press Display Utilities to create form.", vbExclamation, "Invalid Operation": Exit Sub
Dim lastG As Long: lastG = sheets("Global").Cells(Rows.Count, 17).End(xlUp).row
Dim cVat As Boolean: cVat = InStr(1, sheets("Payment Form").Range("A20").value, "THE VAT SHOWN IS YOUR OUTPUT TAX DUE TO CUSTOMS AND EXCISE")
If sheets("PAYMENT FORM").Cells(35 - cVat * 5, 12) >= 1 Then: MsgBox "It appears you have already split the jobs, this operation can only be performed once.", vbExclamation, "Invalid Operation": Exit Sub
For j = 0 To UserForm2.ComboBox2.ListCount - 1
noFind(j, 4) = 0
For i = 3 To lastG
If noFind(j, 0) = sheets("Global").Cells(i, 17) Then
k = i
strWS = UserForm2.ComboBox2.List(j, 1)
On Error Resume Next '<~~ if the worksheet in the next line does not exist, go make one
If Len(Worksheets(strWS).Name) = 0 Then
With ThisWorkbook
On Error GoTo 0
Dim nStr As String: With sheets("Payment Form").Range("C9"): nStr = Right(.value, Len(.value) - Len(Left(.value, InStr(.value, "- ")))): End With
Dim CCName As Variant: CCName = UserForm2.ComboBox2.List(j, 2)
Dim lastRow As Long: lastRow = sheets("Payment Form").Range("U36:U53").End(xlDown).row
Dim strRng As String: strRng = Array("A18:A34", "A23:A39")(-1 * cVat)
Dim lastRow2 As Long: lastRow2 = sheets("Payment Form").Range(strRng).End(xlDown).row
Dim wsTemplate As Worksheet: Set wsTemplate = ThisWorkbook.sheets("Template")
Dim wsNew As Worksheet
With sheets("Payment Form")
For Each cell In .Range(strRng)
If Len(cell) = 0 Then
If sheets("Payment Form").Range("C9").value = "Network" Then
cell.Offset.value = strWS & " - " & nStr & ": " & CCName
Else
cell.Offset.value = strWS & " -" & nStr & ": " & CCName
End If
Exit For
End If
Next cell
End With
With wsNew
wsTemplate.Visible = True
wsTemplate.Copy before:=sheets("Details"): Set wsNew = ActiveSheet
wsTemplate.Visible = False
wsNew.Name = strWS
wsNew.Range("D4").value = sheets("Payment Form").Range(strRng).End(xlDown).value
wsNew.Range("D6").value = sheets("Payment Form").Range("L11").value
wsNew.Range("D8").value = sheets("Payment Form").Range("C9").value
wsNew.Range("D10").value = sheets("Payment Form").Range("C11").value
End With
With .sheets("Payment Form")
.Activate
.Range("J" & lastRow2 + 1).value = 0
.Range("L" & lastRow2 + 1).Formula = "=N" & lastRow2 + 1 & "-J" & lastRow2 + 1 & ""
.Range("N" & lastRow2 + 1).Formula = "='" & strWS & "'!L20"
.Range("U" & lastRow + 1).value = strWS & ": "
.Range("V" & lastRow + 1).Formula = "='" & strWS & "'!I21"
.Range("W" & lastRow + 1).Formula = "='" & strWS & "'!I23"
.Range("X" & lastRow + 1).Formula = "='" & strWS & "'!K21"
End With
End With
End If '<~~~ end new sheet
On Error GoTo 0
While sheets("Global").Cells(k + 1, 17).value = noFind(j, 0) And k < lastG
k = k + 1
Wend
Set rngCPY = sheets("Global").Range("Q" & i & ":Q" & k).EntireRow
With Worksheets(strWS)
rngCPY.Copy
.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Insert shift:=xlDown
End With
noFind(j, 4) = noFind(j, 4) + k - i + 1
i = k
End If
Next i
Next j
With Application: .ScreenUpdating = True: .EnableEvents = True: .CutCopyMode = True: End With
'noFind(x, y) > x = item / y: 0 = name / y: 4 = counter
noFind(0, 0) = noFind(0, 0) & " " & noFind(0, 4) & " times copied"
For i = 1 To UBound(noFind)
noFind(0, 0) = noFind(0, 0) & vbLf & noFind(i, 0) & " " & noFind(i, 4) & " times copied"
Next
MsgBox noFind(0, 0)
End Sub
This is what is currently being displayed by the MsgBox:
This is how I want the MsgBox to display the information:
I want it to show the sheet names, then how many rows have been copied to it.
Below that the total number of rows copied.
Then if required, below that display errors found on the global sheet along with how many times you found that value. I.e (BRERRORS) <- This is the cell value.
If possible below that, maybe a total number of errors found on the sheet as well.
At the very bottom, a total number of rows that were searched in the global sheet, this will be used for comparison, so if the total number of rows copied doesn't match the total number of the global sheet then the user will know they need to copied some rows manually after checking the rows value.
If it helps here is the original code without the code for the MsgBox, if you can think of a better way to do it.
Private Sub btnSplitJobs_Click()
Dim i As Long, j As Long, k As Long, strWS As String, rngCPY As Range
With Application: .ScreenUpdating = False: .EnableEvents = False: .CutCopyMode = False: End With
If Range("L9") = "" Then: MsgBox "You can't Split the Jobs at this stage. " & vbLf & vbLf & "Please create the form for the Sub-Contractor First." & vbLf & vbLf & "Please press Display Utilities to create form.", vbExclamation, "Invalid Operation": Exit Sub
Dim lastG As Long: lastG = sheets("Global").Cells(Rows.Count, "Q").End(xlUp).row
Dim cVat As Boolean: cVat = InStr(1, sheets("Payment Form").Range("A20").value, "THE VAT SHOWN IS YOUR OUTPUT TAX DUE TO CUSTOMS AND EXCISE")
If sheets("PAYMENT FORM").Cells(35 - cVat * 5, 12) >= 1 Then: MsgBox "It appears you have already split the jobs, this operation can only be performed once.", vbExclamation, "Invalid Operation": Exit Sub
For j = 0 To UserForm2.ComboBox2.ListCount - 1
currval = UserForm2.ComboBox2.List(j, 0)
For i = 3 To lastG
If currval = sheets("Global").Cells(i, "Q") Then
k = i
strWS = UserForm2.ComboBox2.List(j, 1)
On Error Resume Next '<~~ if the worksheet in the next line does not exist, go make one
If Len(Worksheets(strWS).Name) = 0 Then
With ThisWorkbook
On Error GoTo 0
Dim nStr As String: With sheets("Payment Form").Range("C9"): nStr = Right(.value, Len(.value) - Len(Left(.value, InStr(.value, "- ")))): End With
Dim CCName As Variant: CCName = UserForm2.ComboBox2.List(j, 2)
Dim lastRow As Long: lastRow = sheets("Payment Form").Range("U36:U53").End(xlDown).row
Dim strRng As String: strRng = Array("A18:A34", "A23:A39")(-1 * cVat)
Dim lastRow2 As Long: lastRow2 = sheets("Payment Form").Range(strRng).End(xlDown).row
Dim wsTemplate As Worksheet: Set wsTemplate = ThisWorkbook.sheets("Template")
Dim wsNew As Worksheet
With sheets("Payment Form")
For Each cell In .Range(strRng)
If Len(cell) = 0 Then
If sheets("Payment Form").Range("C9").value = "Network" Then
cell.Offset.value = strWS & " - " & nStr & ": " & CCName
Else
cell.Offset.value = strWS & " -" & nStr & ": " & CCName
End If
Exit For
End If
Next cell
End With
With wsNew
wsTemplate.Visible = True
wsTemplate.Copy before:=sheets("Details"): Set wsNew = ActiveSheet
wsTemplate.Visible = False
wsNew.Name = strWS
wsNew.Range("D4").value = sheets("Payment Form").Range(strRng).End(xlDown).value
wsNew.Range("D6").value = sheets("Payment Form").Range("L11").value
wsNew.Range("D8").value = sheets("Payment Form").Range("C9").value
wsNew.Range("D10").value = sheets("Payment Form").Range("C11").value
End With
With .sheets("Payment Form")
.Activate
.Range("J" & lastRow2 + 1).value = 0
.Range("L" & lastRow2 + 1).Formula = "=N" & lastRow2 + 1 & "-J" & lastRow2 + 1 & ""
.Range("N" & lastRow2 + 1).Formula = "='" & strWS & "'!L20"
.Range("U" & lastRow + 1).value = strWS & ": "
.Range("V" & lastRow + 1).Formula = "='" & strWS & "'!I21"
.Range("W" & lastRow + 1).Formula = "='" & strWS & "'!I23"
.Range("X" & lastRow + 1).Formula = "='" & strWS & "'!K21"
End With
End With
End If '<~~~ end new sheet
While sheets("Global").Cells(k + 1, 17).value = currval And k < lastG
k = k + 1
Wend
Set rngCPY = sheets("Global").Range("Q" & i & ":Q" & k).EntireRow
With Worksheets(strWS)
rngCPY.Copy
.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Insert shift:=xlDown
End With
i = k
End If
Next i
Next j
With Application: .ScreenUpdating = True: .EnableEvents = True: .CutCopyMode = True: End With
End Sub
I am still newer to VBA and have been trying everything I can think of to get this accomplished before asking for help, but cannot figure it out.
I have an excel file with multiple tabs. I am only concerned with 2 of them. I need to combine rows based off of their values not being blank from tab "Roadmap" into column B on tab "PPPP". The code I have will do that for the first set of data, but then replaces that data with the second set.
Sub Move_PPPP()
Sheets("PPPP").Select
Rows("2:1000").Select
Selection.ClearContents
Dim rowCount2 As Long, shtSrc As Worksheet
Dim shtDest As Worksheet
Dim rng2 As Range
Dim currentRow As Long
Set shtSrc = Sheets("Roadmap")
Set shtDest = Sheets("PPPP")
rowCount2 = shtSrc.Cells(Rows.Count, "C").End(xlUp).Row
Set rng2 = shtSrc.Range("C6:C" & rowCount2)
currentRow = 2
For Each cell2 In rng2.Cells
If cell2.Value <> "" Then
shtDest.Range("B" & currentRow).Value2 = " " & cell2.Text & " - " & cell2.Offset(0, 10).Text
shtDest.Range("B" & currentRow).Value2 = " " & cell2.Text & " - " & cell2.Offset(0, 11).Text
shtDest.Range("B" & currentRow).Value2 = " " & cell2.Text & " - " & cell2.Offset(0, 12).Text
currentRow = currentRow + 1
ElseIf cell2.Value = "" Then
End If
Next cell2
End Sub
I have tried to add a range for my destination sheet, but doing that is only giving me 9 rows of the last row of data from tab "Roadmap"
Sub Move_PPPP()
Sheets("PPPP").Select
Rows("2:1000").Select
Selection.ClearContents
Dim rowCount2 As Long, shtSrc As Worksheet
Dim columnCount As Long
Dim shtDest As Worksheet
Dim rng2 As Range
Dim rng As Range
Dim currentRow As Long
Set shtSrc = Sheets("Roadmap")
Set shtDest = Sheets("PPPP")
rowCount2 = shtSrc.Cells(Rows.Count, "C").End(xlUp).Row
columnCount = shtDest.Cells(Columns.Count, "B").End(xlUp).Row
Set rng2 = shtSrc.Range("C6:C" & rowCount2)
Set rng = shtDest.Range("B2:B" & columnCount & currentRow)
currentRow = 2
For Each cell2 In rng2.Cells
If cell2.Value <> "" Then
rng.Value = " " & cell2.Text & " - " & cell2.Offset(0, 10).Text
currentRow = currentRow + 1
ElseIf cell2.Value = "" Then
End If
Next cell2
End Sub
Sample Data
Roadmap Tab
Column: C D E F G H I J K L M
Headers: Project Status Open Closed Name P1 P2 P3 P4 P5 P6
Row 1: FISMA New Yes No Albert na na na na New Day Old Data
Row 2: QRD Closed No Yes Albert na na na na na Closed
Desired Outcome. Combine Column C with Column M when M <> blank, loop through entire row and put that data in column B of PPPP tab. Then combine column C with N when N <> blank and put that on PPPP tab, column B under the data from column M.
PPPP Tab
Cell B2
FISMA - New Day
Cell B4
FISMA - Old Data
QRD - Closed
SOLUTION:
Sub Move_PPPP()
Sheets("PPPP").Select
Rows("2:1000").Select
Selection.ClearContents
Dim rowCount2 As Long, shtSrc As Worksheet
Dim shtDest As Worksheet
Dim rng2 As Range
Dim currentRow As Long
Set shtSrc = Sheets("Roadmap")
Set shtDest = Sheets("PPPP")
rowCount2 = shtSrc.Cells(Rows.Count, "C").End(xlUp).Row
Set rng2 = shtSrc.Range("C6:C" & rowCount2)
currentRow = shtDest.Range("A" & Rows.Count).End(xlUp).Row
For Each cell2 In rng2.Cells
If cell2.Value2 <> "" Then
shtDest.Range("A" & currentRow).Value2 = " " & cell2.Text & " - " & cell2.Offset(0, 9).Text
currentRow = currentRow + 1
ElseIf cell2.Value = "" Then
End If
Next cell2
Set rng2 = shtSrc.Range("C6:C" & rowCount2)
currentRow = shtDest.Range("A" & Rows.Count).End(xlUp).Row + 1
For Each cell2 In rng2.Cells
If cell2.Value2 <> "" Then
shtDest.Range("A" & currentRow + 1).Value2 = " " & cell2.Text & " - " & cell2.Offset(0, 10).Text
currentRow = currentRow + 1
ElseIf cell2.Value = "" Then
End If
Next cell2
Set rng2 = shtSrc.Range("C6:C" & rowCount2)
currentRow = shtDest.Range("A" & Rows.Count).End(xlUp).Row + 1
For Each cell2 In rng2.Cells
If cell2.Value2 <> "" Then
shtDest.Range("A" & currentRow + 1).Value2 = " " & cell2.Text & " - " & cell2.Offset(0, 11).Text
currentRow = currentRow + 1
ElseIf cell2.Value = "" Then
End If
Next cell2
Set rng2 = shtSrc.Range("C6:C" & rowCount2)
currentRow = shtDest.Range("A" & Rows.Count).End(xlUp).Row + 1
For Each cell2 In rng2.Cells
If cell2.Value2 <> "" Then
shtDest.Range("A" & currentRow + 1).Value2 = " " & cell2.Text & " - " & cell2.Offset(0, 12).Text
currentRow = currentRow + 1
ElseIf cell2.Value = "" Then
End If
Next cell2
End Sub
On the first version, try this :
Sub Move_PPPP()
Sheets("PPPP").Select
Rows("2:1000").Select
Selection.ClearContents
Dim rowCount2 As Long, shtSrc As Worksheet
Dim shtDest As Worksheet
Dim rng2 As Range
Dim currentRow As Long
Set shtSrc = Sheets("Roadmap")
Set shtDest = Sheets("PPPP")
rowCount2 = shtSrc.Cells(Rows.Count, "C").End(xlUp).Row
Set rng2 = shtSrc.Range("C6:C" & rowCount2)
currentRow = shtDest.Range("B" & Rows.Count).End(xlUp).Row
For Each cell2 In rng2.Cells
If cell2.Value <> "" Then
shtDest.Range("B" & currentRow).Value2 = " " & cell2.Text & " - " & cell2.Offset(0, 10).Text
shtDest.Range("B" & currentRow + 1).Value2 = " " & cell2.Text & " - " & cell2.Offset(0, 11).Text
shtDest.Range("B" & currentRow + 2).Value2 = " " & cell2.Text & " - " & cell2.Offset(0, 12).Text
currentRow = currentRow + 1
ElseIf cell2.Value = "" Then
End If
Next cell2
Set rng2 = shtSrc.Range("D6:D" & rowCount2)
currentRow = shtDest.Range("B" & Rows.Count).End(xlUp).Row + 1
For Each cell2 In rng2.Cells
If cell2.Value <> "" Then
shtDest.Range("B" & currentRow).Value2 = " " & cell2.Text & " - " & cell2.Offset(0, 10).Text
shtDest.Range("B" & currentRow + 1).Value2 = " " & cell2.Text & " - " & cell2.Offset(0, 11).Text
shtDest.Range("B" & currentRow + 2).Value2 = " " & cell2.Text & " - " & cell2.Offset(0, 12).Text
currentRow = currentRow + 1
ElseIf cell2.Value = "" Then
End If
Next cell2
End Sub