I recorded a macro that VLOOKUPs from Sheet "P&L" (the first tab that holds all of the data) and filters down in the current sheet until the data in column A runs out. It works; however, I need this code to function for the remaining sheets. These are updated monthly. There will be a different number of inputs in Column A in each sheet. These are all ID #s I'm using to vlookup information from the P&L tab.
When I wrote this macro as a FoorLoopIndex, I keep getting "Compile error: invalid or unqualified" messages.
I do not have any experiences with macros -- I'm struggling to find my error.
Sub update_gp_profits()
Dim StartIndex, EndIndex, LoopIndex As Integer
StartIndex = Sheets("P&L").Index + 1
EndIndex = Sheets("Sheet4").Index - 1
For LoopIndex = StartIndex To EndIndex
lastrow = .Range("A" & .Rows.Count).End(xlUp).Row
.Range("B2:B" & lastrow).Formula = "=+VLOOKUP(RC[-1],'P&L'!R15C3:R29702C4,2,FALSE)"
Range("C2").Select
.Range("C2:C" & lastrow).Formula = "=+VLOOKUP(RC[-2],'P&L'!R15C3:R29702C5,3,FALSE)"
Range("D2").Select
.Range("D2:D" & lastrow).Formula = "=+VLOOKUP(RC[-3],'P&L'!R15C3:R29702C6,4,FALSE)"
Range("E2").Select
.Range("E2:E" & lastrow).Formula = "=+VLOOKUP(RC[-4],'P&L'!R15C3:R29702C17,15,FALSE)"
Range("F2").Select
.Range("F2:F" & lastrow).Formula = "=+VLOOKUP(RC[-5],'P&L'!R15C3:R29702C18,16,FALSE)"
Range("J2").Select
.Range("k2:k" & lastrow).Formula = "=+VLOOKUP(RC[-10],'P&L'!R15C3:R29702C160,158,FALSE)"
Range("k2").Select
Next LoopIndex
End Sub
Try this one,
Sub update_gp_profits()
Dim ws As Worksheet
Dim rng As Range
Dim lRow As Long
Set ws = ActiveSheet
'
With ws
lRow = ws.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row ' Last row
Set rng = .Range("A2" & ":" & "A" & lRow) ' This is your range
rng.Offset(0, 1).FormulaR1C1 = "=VLOOKUP(RC[-1],'P&L'!R15C3:R29702C4,2,FALSE)"
rng.Offset(0, 2).FormulaR1C1 = "=VLOOKUP(RC[-2],'P&L'!R15C3:R29702C5,3,FALSE)"
rng.Offset(0, 3).FormulaR1C1 = "=VLOOKUP(RC[-3],'P&L'!R15C3:R29702C6,4,FALSE)"
rng.Offset(0, 4).FormulaR1C1 = "=VLOOKUP(RC[-4],'P&L'!R15C3:R29702C17,15,FALSE)"
rng.Offset(0, 5).FormulaR1C1 = "=VLOOKUP(RC[-5],'P&L'!R15C3:R29702C18,16,FALSE)"
rng.Offset(0, 10).FormulaR1C1 = "=VLOOKUP(RC[-10],'P&L'!R15C3:R29702C160,158,FALSE)"
Debug.Print rng.Address
End With
End Sub
Try below code it will loop all the rows on the sheet4.
max num of row in 2010 office = https://stackoverflow.com/a/527026/1411000
https://stackoverflow.com/a/527026/1411000
Sub update_gp_profits()
Dim StartIndex, EndIndex, LoopIndex As Integer
StartIndex = Sheets("Sheet4").).Index + 1
EndIndex = 1048576
For LoopIndex = StartIndex To EndIndex
lastrow = .Range("A" & .Rows.Count).End(xlUp).Row
.Range("B2:B" & lastrow).Formula = "=+VLOOKUP(RC[-1],'P&L'!R15C3:R29702C4,2,FALSE)"
Range("C2").Select
.Range("C2:C" & lastrow).Formula = "=+VLOOKUP(RC[-2],'P&L'!R15C3:R29702C5,3,FALSE)"
Range("D2").Select
.Range("D2:D" & lastrow).Formula = "=+VLOOKUP(RC[-3],'P&L'!R15C3:R29702C6,4,FALSE)"
Range("E2").Select
.Range("E2:E" & lastrow).Formula = "=+VLOOKUP(RC[-4],'P&L'!R15C3:R29702C17,15,FALSE)"
Range("F2").Select
.Range("F2:F" & lastrow).Formula = "=+VLOOKUP(RC[-5],'P&L'!R15C3:R29702C18,16,FALSE)"
Range("J2").Select
.Range("k2:k" & lastrow).Formula = "=+VLOOKUP(RC[-10],'P&L'!R15C3:R29702C160,158,FALSE)"
Range("k2").Select
Next LoopIndex
End Sub
Related
I'm trying to only allow a new row to be inserted as long as not columns E & F have not been filtered.
Sub addNewRow()
ThisWorkbook.Worksheets("Overall Combination").Unprotect ("password")
' Do not insert a row before the first row.
Const TopRow As Long = 10
' Get the active row number.
Dim rowNum As Long
rowNum = ActiveCell.Row
If (rowNum > TopRow) And Not ActiveSheet.AutoFilter.Filters(5).On And Not ActiveSheet.AutoFilter.Filters(6).On Then
Rows(rowNum).Insert ' Insert a new row.
Set CurRowR1 = Range("O" & ActiveCell.Row).Offset(-1)
Set NewRowR1 = Range("O" & ActiveCell.Row)
CurRowR1.Copy
NewRowR1.PasteSpecial Paste:=xlPasteFormulas
NewRowR1.PasteSpecial Paste:=xlPasteFormats
Application.CutCopyMode = False
Set CurRowR2 = Range("Q" & ActiveCell.Row & ":V" & ActiveCell.Row).Offset(-1)
Set NewRowR2 = Range("Q" & ActiveCell.Row & ":V" & ActiveCell.Row)
CurRowR2.Copy
NewRowR2.PasteSpecial Paste:=xlPasteFormulas
NewRowR2.PasteSpecial Paste:=xlPasteFormats
Application.CutCopyMode = False
Set CurRowR3 = Range("X" & ActiveCell.Row & ":AI" & ActiveCell.Row).Offset(-1)
Set NewRowR3 = Range("X" & ActiveCell.Row & ":AI" & ActiveCell.Row)
CurRowR3.Copy
NewRowR3.PasteSpecial Paste:=xlPasteFormulas
NewRowR3.PasteSpecial Paste:=xlPasteFormats
Application.CutCopyMode = False
Range("D" & ActiveCell.Row).Select
' === add a Check Box ===
Dim oCB As CheckBox
Dim c As Range
Set c = Cells(rowNum, 19)
With c
Set oCB = CheckBoxes.Add(.Left, .Top, .Width, .Height)
oCB.Caption = vbNullString
oCB.Display3DShading = True
oCB.Width = 18.29
oCB.Height = 14.89
End With
Else: MsgBox ("Cannot insert new row while either 'Pneu. Cabinet' or Valve Node' Columns are filtered")
End If
ThisWorkbook.Worksheets("Overall Combination").Protect ("password"), AllowFiltering:=True
End Sub
However I'm getting Run-time error '9': Subscript out of range for
If (rowNum > TopRow) And Not ActiveSheet.AutoFilter.Filters(5).On And Not ActiveSheet.AutoFilter.Filters(6).On Then
I've tried to specify the sheet name rather than use ActiveSheet, but same error. What am I doing wrong?
Ahh thanks for the tip to use .FilterMode, that's what I needed.
Changed to this and now a new row can be inserted using a linked form control button so long as the sheet has not been filtered, which is what I wanted.
The rest of the script copies down formulas and formatting from the row above and adds a check box to column S (19th across).
The form control button used to insert new row also runs a script to re-link all the checkboxes in column S to cells in the same row in another column too.
If the sheet has been filtered and there is an attempt to insert a new row, a message box to say "can't be done..." then exits sub
Sub addNewRow()
ThisWorkbook.Worksheets("Overall Combination").Unprotect ("password")
' Do not insert a row before the first row.
Const TopRow As Long = 10
' Get the active row number.
Dim rowNum As Long
rowNum = ActiveCell.Row
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("Overall Combination")
If ws.FilterMode Then
MsgBox "Cannot insert new row while either 'Pneu. Cabinet' or 'Valve Node' columns are filtered. This would result in formatting and formula errors." & vbCrLf & "Please clear filter before inserting new row"
ElseIf (rowNum > TopRow) Then
Rows(rowNum).Insert ' Insert a new row.
Set CurRowR1 = Range("O" & ActiveCell.Row).Offset(-1)
Set NewRowR1 = Range("O" & ActiveCell.Row)
CurRowR1.Copy
NewRowR1.PasteSpecial Paste:=xlPasteFormulas
NewRowR1.PasteSpecial Paste:=xlPasteFormats
Application.CutCopyMode = False
Set CurRowR2 = Range("Q" & ActiveCell.Row & ":V" & ActiveCell.Row).Offset(-1)
Set NewRowR2 = Range("Q" & ActiveCell.Row & ":V" & ActiveCell.Row)
CurRowR2.Copy
NewRowR2.PasteSpecial Paste:=xlPasteFormulas
NewRowR2.PasteSpecial Paste:=xlPasteFormats
Application.CutCopyMode = False
Set CurRowR3 = Range("X" & ActiveCell.Row & ":AI" & ActiveCell.Row).Offset(-1)
Set NewRowR3 = Range("X" & ActiveCell.Row & ":AI" & ActiveCell.Row)
CurRowR3.Copy
NewRowR3.PasteSpecial Paste:=xlPasteFormulas
NewRowR3.PasteSpecial Paste:=xlPasteFormats
Application.CutCopyMode = False
Range("D" & ActiveCell.Row).Select
' === add a Check Box ===
Dim oCB As CheckBox
Dim c As Range
Set c = Cells(rowNum, 19)
With c
Set oCB = CheckBoxes.Add(.Left, .Top, .Width, .Height)
oCB.Caption = vbNullString
oCB.Display3DShading = True
oCB.Width = 18.29
oCB.Height = 14.89
End With
End If
ThisWorkbook.Worksheets("Overall Combination").Protect ("password"), AllowFiltering:=True
End Sub
I'm using this code for add new items to next blank line.
Private Sub Ekle_Butonu_Click()
Dim LastRow As Long, ws As Worksheet
Set ws = Sayfa1
LastRow = ws.Range("A" & Rows.Count).End(xlUp).Row + 1
ws.Range("A" & LastRow).Value = Tarih_B
ws.Range("C" & LastRow).Value = Kaynak_B
ws.Range("E" & LastRow).Value = Aciklama_B
ws.Range("I" & LastRow).Value = Tutar_B
End Sub
And I want to print just this added line. Can you help me ?.
You need to look into the PageSetup.PrintArea property. For example:
Sub Test()
Dim lr As Long
With Sayfa1
lr = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
.Cells(lr, 1).Value = Tarih_B
.Cells(lr, 3).Value = Kaynak_B
.Cells(lr, 5).Value = Aciklama_B
.Cells(lr, 9).Value = Tutar_B
.PageSetup.PrintArea = Replace("A?,C?,E?,I?", "?", lr)
.PrintOut
End With
End Sub
As per your comment, If I understand you correctly, there are more cells in that same line you want to include:
.PageSetup.PrintArea = Replace("A?:J?", "?", lr)
This is a follow on from How do I get all the different unique combinations of 3 columns using VBA in Excel?
It almost what i need, however, my requirements is that it sums the third column which will contain figures instead of yes/no
Sub sample()
Dim ws As Worksheet
Dim lRow As Long, i As Long, j As Long
Dim col As New Collection
Dim Itm
Dim cField As String
Const deLim As String = "#"
Set ws = ThisWorkbook.Sheets("Sheet1")
With ws
lRow = .Range("A" & .Rows.Count).End(xlUp).Row
For i = 2 To lRow
cField = .Range("A" & i).Value & deLim & _
.Range("B" & i).Value & deLim & _
.Range("C" & i).Value
On Error Resume Next
col.Add cField, CStr(cField)
On Error GoTo 0
Next i
i = 2
.Range("A1:C1").Copy .Range("F1")
.Range("I1").Value = "Count"
For Each Itm In col
.Range("F" & i).Value = Split(Itm, deLim)(0)
.Range("G" & i).Value = Split(Itm, deLim)(1)
.Range("H" & i).Value = Split(Itm, deLim)(2)
For j = 2 To lRow
cField = .Range("A" & j).Value & deLim & _
.Range("B" & j).Value & deLim & _
.Range("C" & j).Value
If Itm = cField Then nCount = nCount + 1
Next
.Range("I" & i).Value = nCount
i = i + 1
nCount = 0
Next Itm
End With
End Sub
This code was originally added by
Siddharth Rout
try this (follows comments)
Option Explicit
Sub Main()
Dim i As Long
Dim dict As Object
Set dict = CreateObject("Scripting.Dictionary")
For i = 4 To Range("A" & Rows.Count).End(xlUp).Row '<-- change 4 and "A" to your data actual upleftmost cell row and column
dict(cells(i, 1).Value & "|" & cells(i, 2).Value) = dict(cells(i, 1).Value & "|" & cells(i, 2).Value) + cells(i, 3).Value '<--| change 3 to your actual "column to sum up" index
Next
With Range("G3").Resize(dict.Count) '<-- change "G3" to your actual upleftmost cell to start writing output data from
.Value = Application.Transpose(dict.Keys)
.TextToColumns Destination:=.cells, DataType:=xlDelimited, Other:=True, OtherChar:="|"
.Offset(, 2).Resize(dict.Count).Value = Application.Transpose(dict.Items) '<--| change 2 to your actual column offset where to start writing summed values form
End With
End Sub
How can I Search for specific name header column "DATA/HORA" and adapt to macro below?
Sub Data()
Dim cell As Range
Dim lastRow As Long
lastRow = Range("A" & Rows.Count).End(xlUp).Row
For Each cell In Range("A1:A" & lastRow)
If InStr(cell.Value, "-") <> 0 Then
cell.Value = RegexReplace(cell.Value, _
"(\d{4})\-(\d{2})\-(\d{2})", "$3/$2/$1")
End If
cell.NumberFormat = "dd/mm/yyyy;#"
Next
End Sub
Function RegexReplace
------
End Function
Replace:
lastRow = Range("A" & Rows.Count).End(xlUp).Row
For Each cell In Range("A1:A" & lastRow)
With:
Dim ColLetr As String
For i = 1 To Columns.Count
If Cells(1, i) = "DATA/HORA" Then
ColLetr = Split(Cells(1, i).Address, "$")(1)
End If
Next
lastRow = Range(ColLetr & Rows.Count).End(xlUp).Row
For Each cell In Range(ColLetr & "1:" & ColLetr & lastRow)
EDIT#1:
To address the Comments:
Dim ColLetr As String
For i = 1 To Columns.Count
If Cells(1, i) = "DATA/HORA" Then
ColLetr = Split(Cells(1, i).Address, "$")(1)
Exit For
End If
Next
If ColLetr = "" Then
MsgBox "DATA/HORA not found"
Exit Sub
End If
lastRow = Range(ColLetr & Rows.Count).End(xlUp).Row
For Each cell In Range(ColLetr & "1:" & ColLetr & lastRow)
The codes below are edited by me to get the results but unlucky to get it. I am trying to compare sheet1 Col A&B with sheet2 Col A&B and result on sheet3. Kindly advise.
Sub ReconcileRegisters()
Dim i As Long, _
LRa As Long, _
LRb As Long, _
rowx As Long
LRa = Sheets("sheet1").Range("A1:B" & Rows.Count).End(xlUp).Row
LRb = Sheets("sheet2").Range("A1:B" & Rows.Count).End(xlUp).Row
rowx = 2
Application.ScreenUpdating = False
For i = 2 To LRa
If IsError(Application.Match(Sheets("sheet1").Range("A1:B" & i).Value, Sheets("sheet2").Range("A1:B" & LRb), 0)) Then
Sheets("sheet3").Range("A" & rowx).Value = Sheets("sheet1").Range("A1:B" & i).Value
rowx = rowx + 1
End If
Next i
For i = 2 To LRb
If IsError(Application.Match(Sheets("sheet2").Range("A1:B" & i).Value, Sheets("sheet1").Range("A1:B" & LRa), 0)) Then
Sheets("sheet3").Range("A" & rowx).Value = Range("A1:B" & i).Value
rowx = rowx + 1
End If
Next i
Application.ScreenUpdating = True
MsgBox "Matching process is complete"
End Sub
If you compare both loops then I would assume that you need Sheets("sheet2") in this second section:
Sheets("sheet3").Range("A" & rowx).Value = Range("A1:B" & i).Value