I am trying to calculate the percentage difference in two columns. I have stored the values in two different dictionaries and calculating the percentage difference. The result is stored in a value = pct_change.
I then want to add it to a list, so i counts how many of the values that had a percentage increase and how many had a percentage decrease. Is it possible to create a new dictionary, store the pct_change as a key, and append the key in the new dictionary? After the loop then counting the number of keys in the dictionary?
I will post my current code below. Note that I am aware of the many defined variables that i am not using.
I hope someone can help me out
Sub benchmark()
Const NETSCONT_SHT3 = "D"
Const NETSCONT_SHT4 = "I"
Const NETSEXP_SHT4 = "H"
Dim wb As Workbook, wbNew As Workbook
Dim ws1 As Worksheet, ws3 As Worksheet, ws4 As Worksheet
Dim iRow As Long, iLastRow, iTargetRow As Long, iCopyRow As Long, NbCont_SHT3 As Long, AmCont_SHT3 As Double
Dim NbCont_SHT4 As Long, AmCont_SHT4 As Double, NbResults As Integer, AmResult As Double, pct_change As Double
Dim msg As String, i As Integer, j As Integer
Dim count As Long, countWB As Integer
Dim WkSht_Src As Worksheet
Dim WkBk_Dest As Workbook
Dim WkSht_Dest As Worksheet
Dim Rng As Range
Dim r As Long
Set wb = ThisWorkbook
Set ws1 = wb.Sheets("BrokerSelect")
Set ws3 = wb.Sheets("ContributionSplitReport")
Set ws4 = wb.Sheets("ContributionExceptionReport")
Dim dict As Object, dictEXP As Object, sKey As Double, ar As Variant
Dim sEXP As Double, arEXP As Variant
Set dict = CreateObject("Scripting.Dictionary")
Set dictEXP = CreateObject("Scripting.Dictionary")
' pct change in expected and actual cont
iLastRow = ws4.Cells(Rows.count, NETSCONT_SHT4).End(xlUp).Row
For iRow = 18 To iLastRow
sKey = ws4.Cells(iRow, NETSCONT_SHT4)
sEXP = ws4.Cells(iRow, NETSEXP_SHT4)
If sKey <> "0" Then
pct_change = (sKey - sEXP) / sKey
MsgBox (pct_Change)
Else
End If
Next
End Sub
For your last request, please replace
MsgBox (pct_Change)
with
Dim d As Long, dE as Long
If pct_Change > 0 Then
dict.Add d, pct_Change: d = d + 1
ElseIf pct_Change < 0 Then
dictEXP.Add dE, pct_Change: dE = dE + 1
End If
'finally:
Debug.Print dict.Count, dictEXP.Count, dictEXP.Items(2)
Related
I am running through a column and storing the value for each row in a dictionary.
if the value does not exists i want to add a cell value on that row to an array/list. In the end i want a sum of all the values in the array.
How do i append the values to an array and sum the values in the array? I hope someone can help
Code
Const NETSCONT_SHT3 = "D"
Const NETSCONT_SHT4 = "I"
Const NETSEXP_SHT4 = "H"
Const MEMBER_SHT4 = "G"
Dim wb As Workbook, wbNew As Workbook
Dim ws1 As Worksheet, ws3 As Worksheet, ws4 As Worksheet
Dim iRow As Long, iLastRow, iTargetRow As Long, iCopyRow As Long, NbCont_SHT3 As Long, AmCont_SHT3 As Double
Dim NbCont_SHT4 As Long, AmCont_SHT4 As Double, NbResults As Integer, AmResult As Double, pct_change As Double
Dim msg As String, i As Integer, j As Integer
Dim count As Long, countWB As Integer
Dim WkSht_Src As Worksheet
Dim WkBk_Dest As Workbook
Dim WkSht_Dest As Worksheet
Dim Rng As Range
Dim r As Long
Dim d As Long, dE As Long
Set wb = ThisWorkbook
Set ws1 = wb.Sheets("BrokerSelect")
Set ws3 = wb.Sheets("ContributionSplitReport")
Set ws4 = wb.Sheets("ContributionExceptionReport")
Dim dict As Object, dictEXP As Object, dictRESULTP As Object, dictRESULTN As Object, dictMEMBER As Object, sKey As Double, ar As Variant
Dim sEXP As Double, sRESP As Double, sRESN As Double, sMEMBER As Integer, arEXP As Variant, arRESP As Variant, arRESN As Variant, arMEMBER As Variant
Set dict = CreateObject("Scripting.Dictionary")
Set dictEXP = CreateObject("Scripting.Dictionary")
Set dictRESULTP = CreateObject("Scripting.Dictionary")
Set dictRESULTN = CreateObject("Scripting.Dictionary")
Set dictMEMBER = CreateObject("Scripting.Dictionary")
iLastRow = ws4.Cells(Rows.count, MEMBER_SHT4).End(xlUp).Row
For iRow = 18 To iLastRow
sMEMBER = ws4.Cells(iRow, MEMBER_SHT4) ' column "G"
sKey = ws4.Cells(iRow, NETSCONT_SHT4) ' column "I"
sEXP = ws4.Cells(iRow, NETSEXP_SHT4) ' column "H"
If dictMEMBER.exists(sMEMBER) Then
dictMEMBER(sMEMBER) = dictMEMBER(sMEMBER) & ";" & iRow
Else
dictMEMBER(sMEMBER) = iRow
If sKey <> "0" Then
pct_change = (sKey - sEXP) / sKey
If pct_change > 0 Then
dictRESULTP.Add d, pct_change: d = d + 1
ElseIf pct_change < 0 Then
dictRESULTN.Add dE, pct_change: dE = dE + 1
End If
End If
'If dictMEMBER(sMEMBER) does not exist I want to append the cell value (irow, i) into an array.
'In the end i want to sum the value of the array
End If
next
I'm not entirely clear about what you wish to achieve but the code below will do most of it. Please try it.
Sub Benchmark()
' This proc needs a reference to 'Miscrosoft Scripting Runtime'
' If you use late binding VBA will do without the reference but you
' won't have the benefit of Intellisense drop-downs while programming.
' Checkmark: Tools > References > Microsoft Scripting Runtime'
Const ConExMember = "G"
Const ConExExp = "H"
Const ConExAct = "I"
Dim Wb As Workbook
Dim WsConEx As Worksheet
Dim Dict As Scripting.Dictionary
Dim Member As String
Dim Expected As Double, Actual As Double
Dim ChangePct As Double
Dim Rl As Long ' last row
Dim R As Long ' rows loop counter
Dim Tmp As Variant
Dim Msg As String, Count(2) As Integer
Set Wb = ThisWorkbook
Set WsConEx = Wb.Sheets("ContributionExceptionReport")
Set Dict = CreateObject("Scripting.Dictionary")
' pct change in expected and actual cont
With WsConEx
Rl = .Cells(.Rows.Count, ConExMember).End(xlUp).Row
For R = 18 To Rl
Member = .Cells(R, ConExMember).Value
Actual = Val(.Cells(R, ConExAct).Value)
Expected = Val(.Cells(R, ConExExp).Value)
On Error Resume Next ' if Actual = 0
ChangePct = (Actual - Expected) / Actual
If Err.Number Then ChangePct = 0
On Error GoTo 0
If Not Dict.Exists(Member) Then
Dict.Add Member, ChangePct
End If
Next R
End With
ChangePct = 0
For Each Tmp In Dict.Keys
ChangePct = ChangePct + Dict(Tmp)
R = Sgn(Dict(Tmp)) + 1
Count(R) = Count(R) + 1
Next Tmp
Msg = "Members: " & Dict.Count & vbCr & _
"Increases: " & Count(2) & vbCr & _
"Decreases: " & Count(1) & vbCr & _
"Unchanged: " & Count(0) & vbCr & _
"Change % : " & Round(ChangePct * 100, 2) & "%"
MsgBox Msg, vbInformation, "Summary"
End Sub
The code will loop through all your members in what was your Ws4. It will skip over duplicates. Unique members will be added to a dictionary with their names (or perhaps ID numbers) as Key and the percentage of change as Item. The result will be one dictionary with all unique names and all the changes.
In the second half of the code this dictionary is examined. Changes are sorted into positive, negative and unchanged and counted for each category. The aggregate change is calculated and the members counted. All of that goes into a message box.
The important change I made is to create pairs of data, with the member ID as key and the change as related information. This data can be evaluated easily, with very few lines of code, whichever way you want.
I update the code as following hoping it would be helpful to you:
Sub AddAndSumMissingDictionary()
'Constants
Const NETSCONT_SHT3 = "D"
Const NETSEXP_SHT4 = "H"
Const NETSCONT_SHT4 = "I"
Const MEMBER_SHT4 = "G"
'ArrayColumns
Const cTotalExpected = 0
Const cTotalNets = 1
Const cTotalNetSplitAVC = 2
'Workbooks & Worksheets
Dim wb As Workbook, wbNew As Workbook
Dim ws1 As Worksheet, ws3 As Worksheet, ws4 As Worksheet
Dim WkSht_Src As Worksheet
Dim WkBk_Dest As Workbook
Dim WkSht_Dest As Worksheet
'Array you Requested
Dim ArrMissingDictionary() As Double
Dim lMissingDictCount As Long
'Iteration Rows & Ranges
Dim iRow As Long, iLastRow As Long, iTargetRow As Long, iCopyRow As Long, NbCont_SHT3 As Long, AmCont_SHT3 As Double
Dim NbCont_SHT4 As Long, AmCont_SHT4 As Double, NbResults As Integer, AmResult As Double, pct_change As Double
Dim msg As String, i As Integer, j As Integer
Dim count As Long, countWB As Integer
Dim Rng As Range
Dim r As Long
Dim d As Long, dE As Long
'Initializing Variables
Set wb = ThisWorkbook
Set ws1 = wb.Sheets("BrokerSelect")
Set ws3 = wb.Sheets("ContributionSplitReport")
Set ws4 = wb.Sheets("ContributionExceptionReport")
Dim dict As Object, dictEXP As Object, dictRESULTP As Object, dictRESULTN As Object, dictMEMBER As Object, sKey As Double, ar As Variant
Dim sEXP As Double, sRESP As Double, sRESN As Double, sMEMBER As Integer, arEXP As Variant, arRESP As Variant, arRESN As Variant, arMEMBER As Variant
'Initializing Dictionaries
Set dict = CreateObject("Scripting.Dictionary")
Set dictEXP = CreateObject("Scripting.Dictionary")
Set dictRESULTP = CreateObject("Scripting.Dictionary")
Set dictRESULTN = CreateObject("Scripting.Dictionary")
Set dictMEMBER = CreateObject("Scripting.Dictionary")
'Set Missing lMissingDictCount to 0
lMissingDictCount = 0
'Get the Last Row
iLastRow = ws4.Cells(Rows.count, MEMBER_SHT4).End(xlUp).Row
'Iteration Process
For iRow = 18 To iLastRow
sMEMBER = ws4.Cells(iRow, MEMBER_SHT4) ' column "G"
sKey = ws4.Cells(iRow, NETSCONT_SHT4) ' column "I"
sEXP = ws4.Cells(iRow, NETSEXP_SHT4) ' column "H"
'Checking Existance of Dictionary Entry
If dictMEMBER.exists(sMEMBER) Then
'I think this should be like this
dictMEMBER.Key(sMEMBER) = dictMEMBER(sMEMBER) & ";" & iRow 'dictMEMBER(sMEMBER) = dictMEMBER(sMEMBER) & ";" & iRow
Else
dictMEMBER.Key(sMEMBER) = iRow 'dictMEMBER(sMEMBER) = iRow
If sKey <> "0" Then
pct_change = (sKey - sEXP) / sKey
If pct_change > 0 Then
dictRESULTP.Add d, pct_change: d = d + 1
ElseIf pct_change < 0 Then
dictRESULTN.Add dE, pct_change: dE = dE + 1
End If
End If
'Increment lMissingDictCount
lMissingDictCount = lMissingDictCount + 1 'UBound(ArrMissingDictionary, 1) + 1
'Adding the Array:
ReDim Preserve ArrMissingDictionary(2, lMissingDictCount) 'Increasing the Array Row while keeping its content
ArrMissingDictionary(cTotalExpected, lMissingDictCount) = ws4.Cells(iRow, NETSEXP_SHT4)
ArrMissingDictionary(cTotalNets, lMissingDictCount) = ws4.Cells(iRow, NETSCONT_SHT4)
ArrMissingDictionary(cTotalNetSplitAVC, lMissingDictCount) = ws4.Cells(iRow, MEMBER_SHT4)
'If dictMEMBER(sMEMBER) does not exist I want to append the cell value (irow, i) into an array.
End If
Next iRow
'In the end i want to sum the value of the array
'I'm reusing the iRow again
Dim dTotalExpected As Double, dTotalNets As Double, dTotalNetSplitAVC As Double
For iRow = LBound(ArrMissingDictionary, 1) To UBound(ArrMissingDictionary, 1)
dTotalExpected = dTotalExpected + ArrMissingDictionary(cTotalExpected, iRow) 'Sum Missing on Col "H"
dTotalNets = dTotalNets + ArrMissingDictionary(cTotalNets, iRow) 'Sum Missing on Col "I"
dTotalNetSplitAVC = dTotalNetSplitAVC + ArrMissingDictionary(cTotalNetSplitAVC, iRow) 'Sum Missing on Col "G"
Next iRow
'You can affect the dTotalExpected, dTotalNets and dTotalNetSplitAVC for your purpose
End Sub
Hopefully, this will solve your issue
picture of sheet where I want to take the values from.
I have a sheet where I want to iterate through one column. Column "E" in sheet3. There are many duplicates in this column. It must take the value, and insert it into sheet1 column "C". It is important that I do not have duplicates in sheet1. I have tried to solve this problem using dictionaries. But I cannot get it to work. Can someone help me?
This is the code i got for now. I am stuck and can not get further.
Sub test()
Const START_ROW = 11
Const MAX_ROW = 40
Const CODE_SHT1 = "C"
Const CODE_SHT4 = "E"
Const CVR_SHT4 = "C"
Const CVR_SHT3 = "C"
Const BROKER_SHT4 = "E"
' sheet 4 columns
'C - Employer CVR MD
'D - Employer name
'E - broker code
'F - Broker name
'? Employer CVR CER
Dim wb As Workbook, wbNew As Workbook
Dim ws1 As Worksheet, ws3 As Worksheet, ws4 As Worksheet, wsNew As Worksheet
Dim iRow As Long, iLastRow, iTargetRow As Long, iCopyRow As Long
Dim msg As String, i As Integer, j As Integer
Dim count As Long, countWB As Integer
Dim WkSht_Src As Worksheet
Dim WkBk_Dest As Workbook
Dim WkSht_Dest As Worksheet
Dim Rng As Range
Set wb = ThisWorkbook
Set ws1 = wb.Sheets("BrokerSelect")
Set ws3 = wb.Sheets("ContributionExceptionReport")
Set ws4 = wb.Sheets("MasterData")
Dim dict As Object, dictCVR As Object, dictBROKER As Object, sKey As String, ar As Variant
Dim sCVR As String, arCVR As Variant
Dim sBROKER As String, arBROKER As Variant
Set dict = CreateObject("Scripting.Dictionary")
Set dictCVR = CreateObject("Scripting.Dictionary")
Set dictBROKER = CreateObject("Scripting.Dictionary")
' Get broker code + broker name from sheet 3 and insert into sheet one
iLastRow = ws4.Cells(Rows.count, BROKER_SHT4).End(xlUp).Row
For iRow = 18 To iLastRow
sKey = ws4.Cells(iRow, BROKER_SHT4)
If dictBROKER.exist(sKey) Then
dictBROKER(sKey) = dictBROKER(sKey) & ";" & iRow ' matched row on sheet 1
Else
dictBROKER(sKey) = iRow
End If
MsgBox (dict(sKey))
Next
End Sub
your code has to be amended from (at least):
a Next statament more (that by the end)
use of dict instead of dictBROKER
incorrect indentation (to have more chance to understand and control it)
so here it is after those changes
Sub Test()
Const START_ROW = 11
Const MAX_ROW = 40
Const BROKER_SHT4 = "E"
Dim wb As Workbook, wbNew As Workbook
Dim ws1 As Worksheet, ws3 As Worksheet, ws4 As Worksheet, wsNew As Worksheet
Dim iRow As Long, iLastRow, iTargetRow As Long, iCopyRow As Long
Dim msg As String, i As Integer, j As Integer
Dim count As Long, countWB As Integer
Dim WkSht_Src As Worksheet
Dim WkBk_Dest As Workbook
Dim WkSht_Dest As Worksheet
Dim Rng As Range
Set wb = ThisWorkbook
Set ws1 = wb.Sheets("BrokerSelect")
Set ws3 = wb.Sheets("ContributionExceptionReport")
Set ws4 = wb.Sheets("MasterData")
Dim dictBROKER As Object, dictCVR As Object, sKey As String, ar As Variant
Dim sCVR As String, arCVR As Variant
Dim sBROKER As String, arBROKER As Variant
Set dictBROKER = CreateObject("Scripting.Dictionary")
' Get broker code + broker name from sheet 3 and insert into sheet one
iLastRow = ws4.Cells(Rows.count, BROKER_SHT4).End(xlUp).Row
For iRow = 13 To iLastRow
sKey = ws4.Cells(iRow, BROKER_SHT4)
If dictBROKER.exists(sKey) Then
dictBROKER(sKey) = dictBROKER(sKey) & ";" & iRow ' matched row on sheet 1
Else
dictBROKER(sKey) = iRow
End If
MsgBox (dictBROKER(sKey))
Next
' add cvr records from sheet3 if any
sBROKER = ws4.Cells(iCopyRow, BROKER_SHT4)
If dictBROKER.exists(sBROKER) Then
arBROKER = Split(dictBROKER(sBROKER), ";")
For j = LBound(arBROKER) To UBound(arBROKER)
If j > 0 Then iTargetRow = iTargetRow + 1
' copy col C to D
iCopyRow = arBROKER(j)
Debug.Print sBROKER, j, iCopyRow
Next
Else
count = count + 1
End If
End Sub
Sub exportSheet2()
Const START_ROW = 11
Const MAX_ROW = 40
Const BROKER_SHT4 = "E"
Dim wb As Workbook, wbNew As Workbook
Dim ws1 As Worksheet, ws3 As Worksheet, ws4 As Worksheet, wsNew As Worksheet
Dim iRow As Long, iLastRow, iTargetRow As Long, iCopyRow As Long
Dim msg As String, i As Integer, j As Integer
Dim count As Long, countWB As Integer
Dim WkSht_Src As Worksheet
Dim WkBk_Dest As Workbook
Dim WkSht_Dest As Worksheet
Dim Rng As Range
Dim r As Long
Set wb = ThisWorkbook
Set ws1 = wb.Sheets("sheet1")
Set ws3 = wb.Sheets("sheet3")
Set ws4 = wb.Sheets("sheet4")
Dim dict As Object, dictCVR As Object, sKey As String, ar As Variant
Dim sCVR As String, arCVR As Variant
Dim sBROKER As String, arBROKER As Variant
Set dict = CreateObject("Scripting.Dictionary")
Set dictCVR = CreateObject("Scripting.Dictionary")
Set dictBROKER = CreateObject("Scripting.Dictionary")
' Get broker code + broker name from sheet 3 and insert into sheet one
iLastRow = ws4.Cells(Rows.count, BROKER_SHT4).End(xlUp).Row
r = 11
For iRow = 13 To iLastRow
sKey = ws4.Cells(iRow, BROKER_SHT4)
If dictBROKER.exists(sKey) Then
dictBROKER(sKey) = dictBROKER(sKey) & ";" & iRow ' matched row on sheet 1
Else
dictBROKER(sKey) = iRow
ws1.Range("E" & r) = sKey
ws1.Range("F" & r) = ws4.Cells(iRow, "F")
r = r + 1
End If
Next
I am trying to:
open an import file
check for identical values of import file in target file in several columns
if matched, update one cell in target file
if not matched, add another row
This is my code so far (I didn't clean it yet):
Public Declare PtrSafe Function SetCurrentDirectoryA Lib "kernel32" (ByVal lpPathName As String) As Long
Sub Import_Macro()
Dim wbData As Workbook
Dim wsData As Worksheet
Dim rngData As Range
Set rngData = Selection
Set wbData = Workbooks(rngData.Parent.Parent.Name)
Set wsData = wbData.Sheets("Fehleranalyse Daten")
'DATA IMPORT
Dim wbImport As Workbook
Dim wsImport As Worksheet
Dim Lastrow_wsData As String
Dim Lastrow_wsData_neu As String
Lastrow_wsData = wsData.Range("A:A").Columns(1).Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
'Import from file
MyPath = Application.ActiveWorkbook.Path
SetCurrentDirectoryA MyPath
strFileToOpen = Application.GetOpenFilename _
(Title:="Bitte Datei für Fehler-Reporting auswählen", _
FileFilter:="Excel Files *.xls*; *.csv (*.xls*; *.csv),")
'Defining names for Import
Dim rngImport As Range
Set rngImport = Selection
Set wbImport = Workbooks(rngImport.Parent.Parent.Name)
Set wsImport = wbImport.Sheets("Sheet1")
Dim Lastrow_Import As Long
Lastrow_Import = wsImport.Range("A:A").Columns(1).Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
Dim AnmelderImport As Long
Dim AnmelderData As Long
Dim AbteilungImport As Long
Dim AbteilungData As Long
Dim VNrImport As Long
Dim VNrData As Long
Dim AuftragsNrImport As Long
Dim AuftragsNrData As Long
Dim VersuchImport As Long
Dim VersuchData As Long
Dim iCol As Long
Dim colnameData As Variant
Dim colnumImport As Variant
Dim lrData As Long
Dim lcData As Long
Dim lcImport As Long
Dim lrs As Long
Dim r As Long
Dim c As Long
Dim iSOP As Long
Dim j As Long
Dim i As Range
Dim k As Range
Dim n As Long
Dim Check As Variant
Dim arr As Variant
'Creating several array I need to either check for matching or copying
VersuchImport = Application.WorksheetFunction.Match("VERSUCH", wsImport.Range("11:11"), 0) 'Ermittlung der Spalte für Versuch
VersuchData = Application.WorksheetFunction.Match("VERSUCH", wsData.Range("1:1"), 0)
AuftragsNrImport = Application.WorksheetFunction.Match("AUFTRAGSNUMMER", wsImport.Range("11:11"), 0) 'Ermittlung der Spalte für Auftragsnr.
AuftragsNrData = Application.WorksheetFunction.Match("AUFTRAGSNUMMER", wsData.Range("1:1"), 0)
TestzweckImport = Application.WorksheetFunction.Match("TESTZWECK", wsImport.Range("11:11"), 0) 'Ermittlung der Spalte für Testzweck
TestzweckData = Application.WorksheetFunction.Match("TESTZWECK", wsData.Range("1:1"), 0)
StatusImport = Application.WorksheetFunction.Match("AUFTRAGSSTATUS", wsImport.Range("11:11"), 0) 'Ermittlung der Spalte für Status
StatusData = Application.WorksheetFunction.Match("AUFTRAGSSTATUS", wsData.Range("1:1"), 0)
Debug.Print "VersuchImport = " & VersuchImport
Debug.Print "VersuchData = " & VersuchData
Debug.Print "AuftragsNrImport = " & AuftragsNrImport
Debug.Print "AuftragsNrData = " & AuftragsNrData
Debug.Print "TestzweckImport = " & TestzweckImport
Debug.Print "TestzweckData = " & TestzweckData
With wsImport
Check = .Range(.Cells(1, VersuchImport).Address, .Cells(Lastrow_Import, VersuchImport).End(xlUp).Address).Value2 & .Range(.Cells(1, AuftragsNrImport).Address, .Cells(Lastrow_Import, Auftragsnr).End(xlUp).Address).Value2
End With
'I'm creating another array with column names to be copied (bayed on target file)
With wsData
lrData = wsData.Range("A:A").Columns(1).Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
lcData = Application.WorksheetFunction.Match("AUFTRAGSSTATUS", .Range("1:1"), 0)
colnameData = Application.Transpose(.Range(.Cells(1, 1), .Cells(1, lcData)).Value)
End With
'The corresponding array in the source file
With wsImport
lcImport = Application.WorksheetFunction.Match("SORTIERUNG", .Range("11:11"), 0)
ReDim colnumImport(lcImport, 1)
For iCol = 1 To lcImport
On Error Resume Next
colnumImport(iCol, 1) = .Rows(11).Find(What:=colnameData(iCol, 1), LookIn:=xlValues, lookat:=xlWhole, SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:=False).Column
Next iCol
End With
'This section copies all relevant columns and rows if not matched (not cleaned up though)
Dim lcellData As Range
Dim cellAuftragsNrImport As Range
Dim RngAuftragsNrImport As Variant
Dim RngAuftragsNrData As Variant
Dim Status As Long
Dim cellVersuchImport As Range
Dim RngVersuchImport As Variant
Dim RngVersuchData As Variant
Dim cellStatusImport As Range
Dim RngStatusImport As Variant
Dim RngStatusData As Variant
Dim cellTestzweckImport As Range
Dim RngTestzweckImport As Variant
Dim RngTestzweckData As Variant
Dim iZweck As Long
With wsImport
RngAuftragsNrImport = .Range(.Cells(12, AuftragsNrImport).Address, .Cells(Lastrow_Import, AuftragsNrImport).Address).Value2
RngTestzweckImport = .Range(.Cells(12, TestzweckImport).Address, .Cells(Lastrow_Import, TestzweckImport).Address).Value2
RngVersuchImport = .Range(.Cells(12, VersuchImport).Address, .Cells(Lastrow_Import, VersuchImport).Address).Value2
RngStatusImport = .Range(.Cells(12, StatusImport).Address, .Cells(Lastrow_Import, StatusImport).Address).Value2
End With
With wsData
RngAuftragsNrData = .Range(.Cells(3, AuftragsNrData).Address, .Cells(Lastrow_wsData, AuftragsNrData).Address).Value2
RngVersuchData = .Range(.Cells(3, VersuchData).Address, .Cells(Lastrow_wsData, VersuchData).Address).Value2
RngStatusNrData = .Range(.Cells(3, StatusData).Address, .Cells(Lastrow_wsData, StatusData).Address).Value2
RngTestzweckNrData = .Range(.Cells(3, TestzweckData).Address, .Cells(Lastrow_wsData, TestzweckData).Address).Value2
End With
ReDim arr(0)
For iZweck = LBound(RngTestzweckImport, 1) To UBound(RngTestzweckImport, 1)
If RngTestzweckImport(iZweck, 1) = "Entwicklungstest" Then
ReDim Preserve arr(j)
arr(j) = iZweck + 11
j = j + 1
End If
Next iZweck
For Each cellAuftragsNrImport In RngAuftragsNrImport
With wsData.Cells 'RngAuftragsNrData.Cells
Set i = .Find(cellAuftragsNrImport, LookIn:=xlValues, lookat:=xlWhole)
If Not i Is Nothing Then
k = i.Row
Status = .Cells(k, StatusData).Value
If cellStatusImport.Value <> Status Then
cellStatusImport.Copy Destination:=wsData.Cells(i.Row, StatusData)
End If
Else
With wsData
lrData = Lastrow_wsData
For r = LBound(arr) To UBound(arr)
lrData = .Cells(.Rows.Count, 1).End(xlUp).Row
For c = 1 To lcData
.Cells(lrData + 1, c).Value = wsImport.Cells(arr(r), colnumImport(c, 1)).Value
Next c
Next r
End With
End If
End With
Next
End Sub
All names ending with "Import" are from the source file. All names ending with "Data" are for the target file.
I'm trying to:
Check if items of the source file are already part of the target file. That applies only to lines that contain the value "Entwicklungstest" (see arr).
The criteria to be checked are: AuftragsNr (Order ID), Testzweck and Date.
So far my macro only checks for AuftragsNr. Even for that single criteria, my macro doesn't work.
So basically, if the three criteria from above are not met in the target file, a new line should be added. If the criteria are met, the column "Status" must be updated with the value from the source file.
When executing the macro, all it does is add all lines with "Entwicklungstest" after the last row of the target file.
I would like to use below function from excel on vba. Can I have a good solution?
=IFERROR(VLOOKUP(LEFT(B4,3),B2:G349,5,FALSE),"")
I will appreciate if I get a solution!
Dim lookFor As Range
Dim table_array As Range
Dim varResult As Variant
Dim table_array_col As Integer
Dim lookFor_col As Integer
On Error Resume Next
Set lookFor = Range([B4], Cells(Rows.Count, "B").End(3))
Set table_array = Range("B2:G349")
table_array_col = 5
varResult = Application.VLookup(left(lookFor.Value,3), table_array, table_array_col, 0)
lookFor_col = 2
lookFor.offest(0, lookFor_col) = varResult
Use variant Array.
Sub test()
Dim lookFor As Variant
Dim Table As Variant
Dim vResult() As Variant
Dim table_array_col As Integer
Dim lookFor_col As Integer
Dim c As Integer
Dim LookC As Integer
Dim i As Long, j As Long
Dim r As Long, r2 As Long
c = 5 '<~~ col
LookC = 4
lookFor = Range([B4], Cells(Rows.Count, "B").End(3))
Table = Range("B2:G349")
r = UBound(lookFor, k)
r2 = UBound(Table, 1)
ReDim vResult(1 To r, 1 To 1)
For i = 1 To r
For j = 1 To r2
If Left(lookFor(i, 1), 3) = Table(j, 1) Then
vResult(i, 1) = Table(j, c)
Exit For
End If
Next j
Next i
Cells(2, LookC).Resize(r, 1) = vResult
End Sub
I have a code to copy the entire row if column B contains a certain text ("ACK-", but now I need to copy the entire row directly above the one with the certain text ("ACK-". Is this even possible? Any help will be appreciated.
Sub HEA_Filter()
Dim strArray As Variant
Dim wsSource As Worksheet
Dim wsDest As Worksheet
Dim NoRows As Long
Dim DestNoRows As Long
Dim I As Long
Dim J As Integer
Dim rngCells As Range
Dim rngFind As Range
Dim Found As Boolean
strArray = Array("ack-")
Set wsSource = ActiveSheet
NoRows = wsSource.Range("A65536").End(xlUp).Row
DestNoRows = 1
Set wsDest = Sheets("Real Alarms")
For I = 1 To NoRows
Set rngCells = wsSource.Range("B" & I)
Found = False
For J = 0 To UBound(strArray)
Found = Found Or Not (rngCells.Find(strArray(J)) Is Nothing)
Next J
If Found Then
rngCells.EntireRow.Copy wsDest.Range("A" & DestNoRows)
DestNoRows = DestNoRows + 1
End If
Next I
End Sub
To reference "the row above", you can use the Range.Offset method:
rngCells.Offset(-1).EntireRow.Copy wsDest.Range("A" & DestNoRows)
' ^^^^^^^^^^^^
However, be aware that this raised a runtime error if the range is at row 1, because row 0 does not exist. You might want to add a check for it, for example:
If rngCells.Row > 1 Then rngCells.Offset(-1).EntireRow.Copy ...