Nielsen Nitro range (蓝莓range)刷新
Nielsen Nitro range (蓝莓range)刷新
提问于 2017-03-22 12:23:05
我正在寻找VBA来刷新尼尔森硝基范围。
Nielsen Nitro是一个从数据库中提取数据的应用程序。range也称为Blueberry range，用于刷新数据
我曾尝试使用下面的VBA，但它不起作用
Dim acnNitro As New ACNNITRO
Dim acnNitroUpdate As ACNielsenNitro.ACNNitroUpdate
Dim WS As Worksheet
Dim bret as Boolean
acnNitro.ParentApp = Application
acnNitroUpdate = acnNitro.ACNNitroUpdate
WS = ActiveSheet 'or Set WS = WorkSheets("My Sheet")
bret = acnNitroUpdate.UpdateAllNRanges(WS, ntrSelectGet)
acnNitro = Nothing
acnNitroUpdate = Nothing
WB = Nothing 屏幕截图
我还提供了范围的屏幕截图。
你能给我推荐一下VBA代码吗？
回答 1
Stack Overflow用户
发布于 2017-11-29 19:28:39
我已经为一个项目写了一个类似的代码，可以在下面找到代码。这可能会对你有帮助！
Public Sub NeilsenRefresh()
Dim str_RngDesc As Variant
Dim bRet As Boolean
Dim RngObj As NITRORange
Dim acnNITROUpdt As Object
Dim acnNITRO As Object
Dim NRangeObj As NITRORange
Dim cRange As Object
Dim Bubble As String
Set acnNITRO = CreateObject("ACNielsenNitro.ACNNitro")
Set acnNITRO.ParentApp = ActiveWorkbook.Application
Set acnNITROUpdt = acnNITRO.ACNNitroUpdate
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.Calculation = xlCalculationManual
With ThisWorkbook.Sheets("Macro")
WkbName = .Range("G9").Value
Path = .Range("G12").Value
Bubble = .Range("G15").Value
Atribute = .Range("G18").Value
WkList = .Range("G6").Value
End With
'Sheets("Data").Activate
With ThisWorkbook.Sheets("Data")
lr = .Range("A1048576").End(xlUp).Row
If lr > 1 Then
.Range("Q1:Q" & lr).ClearContents
.Range("A2:A" & lr).ClearContents
.Range("B3:C" & lr).ClearContents
.Range("D2:D" & lr).ClearContents
.Range("R2:R" & lr).ClearContents
.Range("S2:S" & lr).ClearContents
End If
Set WkbList = Workbooks.Open(Path & "\" & WkList & ".xlsx")
Set wks = WkbList.Sheets("Sheet1")
lrw = wks.Range("A1048576").End(xlUp).Row
wks.Range("A2:A" & lrw).Copy
.Range("A2").PasteSpecial Paste:=xlPasteValues
wks.Range("B2:B" & lrw).Copy
.Range("D2").PasteSpecial Paste:=xlPasteValues
lr = .Range("A1048576").End(xlUp).Row
.Range("B2:C" & lr).FillDown
.Calculate
Set wksmiss = ThisWorkbook.Sheets("Missing Records")
lrw = wksmiss.Range("A1048576").End(xlUp).Row
If lrw > 1 Then wksmiss.Range("A2:B" & lrw).ClearContents
.Range("A1:D" & lr).AutoFilter Field:=2, Criteria1:="#N/A"
lrw = .Range("A1048576").End(xlUp).Row
If lrw > 1 Then
.Range("B2:B" & lrw).SpecialCells(xlCellTypeVisible).Copy
wksmiss.Range("A2").PasteSpecial Paste:=xlPasteValues
.Range("D2:D" & lrw).SpecialCells(xlCellTypeVisible).Copy
wksmiss.Range("B2").PasteSpecial Paste:=xlPasteValues
.Range("A2:D" & lrw).SpecialCells(xlCellTypeVisible).Delete Shift:=xlUp
End If
.Range("A1:D" & lr).AutoFilter
.Range("B2:C" & lr).FillDown
.Calculate
.Calculate
.Range("A2:A" & lr).Copy
.Range("Q1").PasteSpecial Paste:=xlPasteValues
.Range("Q1:Q" & lr).RemoveDuplicates Columns:=1, Header:=xlNo
lrd = .Range("Q1048576").End(xlUp).Row
.Range("R1:R" & lrd).FillDown
.Range("S1:S" & lrd).FillDown
.Range("A1").Value = "Cum Name"
.Calculate
For i = 1 To lrd
CumName = .Range("Q" & i).Value
Cnt = .Range("R" & i).Value
FstIndex = .Range("S" & i).Value
RowNo = FstIndex + Cnt - 1
val1 = .Range("C" & RowNo).Value
If CumConcat = "" Then
CumConcat = val1 & ","
Else
val1 = Replace(val1, "MKT", "")
CumConcat = CumConcat & val1 & ","
End If
Next
End With
Set wkb = Workbooks.Open(Path & "\" & WkbName & ".xlsx")
Set RngObj = acnNITRO.ACNRangeUtility.GetNRange(Bubble, ActiveWorkbook)
RngObj.DimCount = 4
RngObj.DimIndex = Atribute
RngObj.DimGetString = CumConcat
str_RngDesc = RngObj.RangeDescription
Set acnNITROUpdt = acnNITRO.ACNNitroUpdate
bRet = acnNITROUpdt.UpdateNRange(ActiveWorkbook, Bubble, 0)
WkbList.Close
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.Calculation = xlCalculationAutomatic
ThisWorkbook.Sheets("Macro").Activate
MsgBox "Nielsen Refresh Completed", vbInformation
End Sub
页面原文内容由Stack Overflow提供。腾讯云小微IT领域专用引擎提供翻译支持
原文链接：
https://stackoverflow.com/questions/42942709
复制相关文章
相似问题
腾讯云开发者
