I want the vba event array & dictionary code because there are 50 thousand row records. the code I made sometimes runs and sometimes it doesn't run maybe something is wrong in my code.If I use the formula it will run very slowly.
I tried to copy 2 lines in the code column but the results of my vba code do not match and can only run if I do only copy 1 line in the code column and I also use it as a form in the receive item sheet, can it work if the formula becomes vba in the MASTER RI (ROLL) sheet?
for information I use excel 2010
Formula information in sheet ("MASTER RI (ROLL)")
Column A :=IF(I2='RECEIVE ITEM'!$F$7,N(A1)+1,N(A1))
Column B :=IF(MAX($C$2:$C$57675)<ROW(1:1),"",VLOOKUP(ROW(1:1),$C$2:$I$57675,7,0))
Column C : =IF(COUNTIF(I$1:I2,I2)=1,MAX(C$1:C1)+1,"")
Column D : =IF([#[SUPPLIER NAME]]="","",VLOOKUP([#[SUPPLIER NAME]],Table2[[#All],[SUPPLIER NAME]:[POSTAL CODE]],3,0))
Column E : =IF([#[SUPPLIER NAME]]="","",VLOOKUP([#[SUPPLIER NAME]],Table2[[#All],[SUPPLIER NAME]:[POSTAL CODE]],4,0))
Column F :=IF([#[SUPPLIER NAME]]="","",VLOOKUP([#[SUPPLIER NAME]],Table2[[#All],[SUPPLIER NAME]:[POSTAL CODE]],6,0))
Column G :=IF([#[QTY IN ACTUAL]]=""," ",[#[QTY IN ACTUAL]])
Column Q : =[#[QTY IN ACTUAL]]*[#rate]
Column T : =[#[QTY IN ACTUAL]]*[#[NEW PRICE]]
Private Sub Worksheet_Change(ByVal Target As Range)
On Error GoTo bm_Safe_Exit
Application.EnableEvents = False
If Intersect(Target, Range("L:L")) Is Nothing Then Exit Sub
Dim fnd As Range
Set fnd = Sheets("MASTER").Range("B:B").Find(Target, LookIn:=xlValues, lookat:=xlWhole)
If Not fnd Is Nothing Then
Target.Offset(, 2).Resize(, 1).Value = Array(fnd.Offset(, 3))
Target.Offset(, 4).Resize(, 1).Value = Array(fnd.Offset(, 6))
Target.Offset(, 6).Resize(, 1).Value = Array(fnd.Offset(, 8))
Target.Offset(, 7).Resize(, 1).Value = Array(fnd.Offset(, 4))
End If
bm_Safe_Exit:
Application.EnableEvents = True
End Sub
MASTER RI (ROLL)
DB SUPPLIER
RECEIVE ITEM
MASTER
Related
i have column "A" each cell in it contains value, i want to look for each value in all sheets in the workbook, when find the matching value, then copy all what's in the left of that cell from the found sheet to the master sheet taking in consideration the bellow points :
Found sheet the range order i want to copy is : E-D-C-B-A (From found cell going left until the beginning of row)
Master Sheet the copied range i want past in this order : A-B-C-D-E (A will be in column "A" the rest will be pasted to the right and go on
i tried with this peace of code but i keep getting errors .
this code does have loop command yet and still struggling with copy all to the left .
enter image description here
Sub Plan_Rout()
Dim Fnd As Range, A1 As Range
Dim Lr As Long
With Sheets("sheet1")
For Each A1 In .Range("A2", .Range("A" & Rows.Count).End(xlUp))
Set Fnd = Sheets("Sheet2").Range("A1:Z50").Find(A1.Value, , xlFormulas, xlWhole,
xlByRows, xlPrevious, False, , False)
If Not Fnd Is Nothing Then A1.Offset(, 1).Value = Fnd.Offset(, -1).Value
If Not Fnd Is Nothing Then A1.Offset(, 2).Value = Fnd.Offset(, -2).Value
'if i add another with offset 3 i get error'
Next A1
End With
End Sub
I am new to VBA and coding in general and I am being tasked with some coding that is proving difficult. I am trying to copy/transpose/paste values from a two-column PivotTable and I need it to paste vertically on another sheet and break on blanks. (see image) I need to copy each group in the PivotTable then transpose paste values vertically on a new worksheet. I believe I need to count populated rows (using an array?) until I get to a blank row then paste the group. I can picture what I need to do but all my coding attempts are way off. Except for the copy/paste, I have no clue how to code this. I cannot figure out how to capture each group of populated rows to be pasted.
' Copy a vertical range (on "FQNID_Sites" sheet) and paste to a horizontal range in column B (next blank row on "BH_FH" sheet)
Dim sourceSheet As Worksheet
Set sourceSheet = ThisWorkbook.Worksheets("FQNID_Sites")
Dim destinationSheet As Worksheet
Set destinationSheet = ThisWorkbook.Worksheets("BH_FH")
Dim cellToPasteTo As Range
' Need to loop through each group breaking on each siteNFID in column D (or break on blanks in column E?)
Set rng = Range("$D$2:$E$" & ActiveSheet.UsedRange.Rows.Count)
For Each cell In rng
Set cellToPasteTo = destinationSheet.Cells(destinationSheet.Rows.Count, "B").End(xlUp).Offset(1, 0)
If cell.Value = "" And Not IsNull(copyStart) Then
copyEnd = cell.Offset(-1, 0).Address
ElseIf cell.Value = "" Then
copyStart = cell.Offset(0, -1).Address
End If
If Not IsNull(copyStart) And Not IsNull(copyEnd) Then
sourceSheet.Range(copyStart & ":" & copyEnd).Select
Selection.Copy
cellToPasteTo.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Transpose:=True
End If
Next cell
Application.CutCopyMode = False
I need it to break on each siteNFID/FQNID then paste values for each group vertically in column B on the BH_FH worksheet.
Example of the input and expected output format
This code will work. Tested on similar data structure. I used the code sheet name in the code `Sheet1'. Change as needed.
Option Explicit
Sub runTranspose()
With Sheet1
Dim lastRow As Long
lastRow = .Cells(.Rows.Count, 4).End(xlUp).Row
'load range starts to transpose
Dim i As Long
For i = 2 To lastRow
If Len(.Cells(i, 5)) = 0 Then
Dim startTranspose As Range
If startTranspose Is Nothing Then
Set startTranspose = .Cells(i, 5)
Else
Set startTranspose = Union(startTranspose, .Cells(i, 5))
End If
End If
Next
Dim c As Range
For Each c In startTranspose
transposeData c
Next
End With
End Sub
Sub transposeData(r As Range)
With Sheet1
Dim nextRow As Long
nextRow = .Cells(.Rows.Count, 8).End(xlUp).Row + 1
Dim fullRange As Range
Set fullRange = Range(r.Offset(1, -1), r.Offset(1).End(xlDown))
Dim arr As Variant
arr = fullRange.Value
.Cells(nextRow,7).Value = r.offset(-1).Value 'to add label
.Cells(nextRow, 8).Resize(2, UBound(arr)).Value = Application.Transpose(arr)
End With
End Sub
I have a macro which performs a vlookup by taking the vendor name in column J and looks for the vendor number in my table array of my vlookup in column C and D. However when I run the macro, something goes visibly wrong with my vlookup. Please see the formula inside the picture attached. Apparently, the part of my table array in my vlookup does not work properly. Actually, I would like that my vlookup returns me a fixed table array (I mean with absolute reference and dollar) from point of origin C5 and as limit point the last row in column D (I mean the limit of my table array should be the last row of column D).
Please see my VBA code below, it seems that this part of my VBA code inside my vlookup is wrong
: C4" & LastRow & "
Thanks a lot for your help.
Xavi
Sub insertvlookuptogetmyvendornumber()
Dim LastRow As Integer
LastRow = Range("D" & Rows.Count).End(xlUp).Row
PenultimateLastRow = Range("J" & Rows.Count).End(xlUp).Offset(-1, 0).Row
Range("I4").Select
ActiveCell.FormulaR1C1 = "Vendor number"
Range("I5").Select
ActiveCell.FormulaR1C1 = "=VLOOKUP(RC[1],R5C3:C4" & LastRow & ",2,0)"
Selection.AutoFill Destination:=Range("I5:I" & PenultimateLastRow), Type:=xlFillDefault
End Sub
As per my comment I would maintain a historic table of names and numbers. I would initially read this into a dictionary and then loop the appropriate columns of the pivottable updating the dictionary value if the name exists. If the name doesn't exist then add the name and number to the dictionary. At the end write it all back out the historic table.
The historic table is your current table where you are trying to do VLookup. In this case, that table would only contain matched pairs which have new values added to it from pivottable, or existing values updated.
To re-iterate, your table on the right, columns I & J should only have matched pairs in it to start with. Hardcoded.
This assumes no subtotal/total rows within pivottable body, though these can be excluded, if present, with an update to the code.
Option Explicit
Public Sub UpdateReferenceTable()
Dim lastRow As Long, dict As Object, ws As Worksheet, pvt As PivotTable, i As Long
Set ws = ThisWorkbook.Worksheets("Sheet1")
Set pvt = ws.PivotTables("PivotTable1")
Set dict = CreateObject("Scripting.Dictionary")
With ws
lastRow = .Cells(.Rows.Count, "I").End(xlUp).Row
End With
Dim initialDictData(), pivotTableUpdates()
initialDictData = ws.Range("I9:J" & lastRow).Value
For i = LBound(initialDictData, 1) To UBound(initialDictData, 1)
dict(initialDictData(i, 2)) = initialDictData(i, 1)
Next
Dim names(), vendorNumbers()
names = Application.Transpose(pvt.PivotFields("Name 1").DataRange.Value)
vendorNumbers = Application.Transpose(pvt.PivotFields("Vendor Number").DataRange.Value)
For i = LBound(names) To UBound(names)
If names(i) <> vbNullString Then
If dict.exists(names(i)) Then
dict(names(i)) = vendorNumbers(i)
Else
dict.Add names(i), vendorNumbers(i)
End If
End If
Next
ws.Range("I9").Resize(dict.Count, 1) = Application.Transpose(dict.items)
ws.Range("J9").Resize(dict.Count, 1) = Application.Transpose(dict.Keys)
End Sub
Data:
I have a dynamic master table on Worksheets("Jobs") that has fixed number of columns (A:M). Columns I and J are formulas.
On a different worksheet I have a textbox that will have a job # specified. I need values in columns L & M to change to "No" for the matching job #. My previous code was working too slow. I'm trying to rewrite the code using an array, but I have a hard time doing so.
The idea is to transfer the entire table to a memory-based array and make your changes to the array, then transfer the updated table data back to the worksheet.
Question is if I do that, wouldn't that clear the content that have formulas. Can I use two arrays from two header based named ranges for column B, then another for columns L:M? Working in that array, just update and transfer the values that just need to be changed.
Thank you for any help anyone can provide.
Here is my code so far:
Sub CloseJobarr()
Dim cell As Range
Dim Txt As String
Dim ws As Worksheet
Dim Arr1 As Variant, Arr2 As Variant
Arr1 = Range("JobCol_Master").Value '<--Column B of Master Data Table that is on ws
Arr2 = Range("OpenSCCols").Value '<--Columns L:M of Master Data Table that is on ws
Set ws = ThisWorkbook.Worksheets("Jobs")
With ThisWorkbook
Txt = .Worksheets("ID").TextBoxID.Text
If Txt <> "" Then
With ws
For Each cell In Arr1
'If job# matches textbox and if job# is to correct region then...
If cell.Text = Txt And .Cells(cell.row, 4).Value = "ID" Then
End If
Next cell
End With
End If
End With
MsgBox "Job not found."
End Sub
Updated Code below using Auto Filter (I'm still experiencing screen flicking). When a job # doesn't match I get a run time error message " no cells were found" and the debug line is: .Range("OpenSCCols").SpecialCells(xlCellTypeVisible).Value = "No"
Option Explicit
Sub CloseJobarraytesting()
ThisWorkbook.Sheets("Jobs").Unprotect Password:="Andersen"
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
On Error GoTo errHndl
Dim cell As Range
Dim Txt As String
Dim ws As Worksheet
With ThisWorkbook.Worksheets("Jobs") '<--| reference relevant worksheet
.Range("JobCol_Master").AutoFilter Field:=2, Criteria1:=Worksheets("ID").TextBoxID.Text '<--| filter its "JobCol_Master" named range on textbox ID
If Application.WorksheetFunction.Subtotal(103, .Cells) > 1 Then '<--| if any cell filtered other than header
.Range("OpenSCCols").SpecialCells(xlCellTypeVisible).Value = "No" '<-- write "OpenSCCols" named range filter cells, corresponding to the filtered ID
Else
MsgBox "Job not found."
End If
.AutoFilterMode = False
End With
CleanUp:
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
ThisWorkbook.Sheets("Jobs").Protect Password:="Andersen"
Exit Sub
errHndl:
MsgBox "Error happened while working on: " + vbCrLf + _
vbCrLf + vbCrLf + "Error " + _
Str(Err.Number) + ": " + Err.Description, vbCritical + vbOKOnly, "Error"
GoTo CleanUp
End Sub
edited to have the code check filtered cells on Range("JobCol_Master")
your aim is to actual filter data, then I believe that an AutoFilter() approach should be considerable fast
assuming you defined both JobCol_Master and OpenSCCols named ranges enclosing their corresponding headers cells, you can simply go like follows
Option Explicit
Sub CloseJobarr()
With ThisWorkbook.Worksheets("Jobs") '<--| reference relevant worksheet
With .Range("JobCol_Master")
.AutoFilter Field:=1, Criteria1:=Worksheets("ID").TextBoxID.Text '<--| filter its "JobCol_Master" named range on textbox ID
If Application.WorksheetFunction.Subtotal(103, .Cells) > 1 Then '<--| if any cell filtered other than header
.Parent.Range("OpenSCCols").SpecialCells(xlCellTypeVisible).Value = "No" '<-- write "OpenSCCols" named range filter cells, corresponding to the filtered ID
Else
MsgBox "Job not found."
End If
End With
.AutoFilterMode = False
End With
End Sub
should your named ranges not contain their headers the code can be easily adapted by means of some Offset() and Resize() method applied on them, but its much easier (and logic) to resize the named ranges and have them enclose their headers
The problem is the following: I have an excel file with multiple worksheets and I needed to copy the G column from every worksheet to a single new worksheet ( the columns should be next to each other or with an empty column between the columns with data). I also wanted to ask if it is possible to put the name of each worksheet above the corresponding column.
Until now, I used this code:
Sub Copy_G_Columns()
Dim ws As Worksheet, i As Long
Application.ScreenUpdating = False
On Error Resume Next
Set ws = Sheets("Gee Columns")
If Err.Number <> 0 Then
ActiveWorkbook.Sheets.Add After:=ActiveWorkbook.Sheets(Sheets.Count): ActiveSheet.Name = "Gee Columns"
On Error GoTo 0
Else
Sheets("Gee Columns").Select
End If
For i = 1 To ActiveWorkbook.Sheets.Count - 1
With Sheets(i)
.Range("G1:G" & .Cells(.Rows.Count, 7).End(xlUp).Row).Copy Cells(2, i * 2 - 1)
Cells(1, i * 2 - 1) = Sheets(i).Name
End With
Next i
Application.ScreenUpdating = True
End Sub
It seems to almost work perfectly. The only problem is that in the new created sheet, the values in the columns have a #DIV/0 error. I think the problem is that the code is copying the formats and not the values.
Here is my interpretation of your code.
Option Explicit
Sub allGEE()
Dim w As Long, wsn As String, vGEEs As Variant
wsn = "Gee Columns"
For w = 1 To Worksheets.Count
With Worksheets(w)
On Error GoTo bm_NeedWorksheet
If .Name <> Worksheets(wsn).Name Then
On Error GoTo bm_Safe_Exit
vGEEs = .Range(.Cells(1, 7), .Cells(Rows.Count, 7).End(xlUp)).Value
vGEEs(1, 1) = .Name
With Worksheets(wsn).Cells(1, w * 2 - 1)
.Resize(UBound(vGEEs, 1), UBound(vGEEs, 2)) = vGEEs
End With
End If
End With
Next w
GoTo bm_Safe_Exit
bm_NeedWorksheet:
On Error GoTo 0
With Worksheets.Add(after:=Sheets(Sheets.Count))
.Name = wsn
End With
Resume
bm_Safe_Exit:
End Sub
I've retained the stagger in the destination cells. I strongly suspect that you were copying formulas across and needed the values only. Transferring values with a variant array (without the clipboard) is quicker. Direct value transfer is also possible but you wanted to put the origin worksheet name into the first cell(s).