I'm trying to convert excel VBA to ppt VBA. The original excel VBA (in "Comparison.xlsm") compared values from other excel workbooks and printed mismatching ones in Comparison.xlsm's Sheet1.
I know my code below (which is my ppt VBA version) is seeing the correct workbooks because when I use MsgBox to print values, I get the correct ones. However, my issue is when I try to print the incorrect values into Comparison.xlsm's Sheet1 at:
mainWB.Worksheets("Sheet1").Range("A" & nextCell).Value = ID_ISS
mainWB.Sheets("Sheet1").Range("B" & nextCell).Value = "Symbol"
mainWB.Sheets("Sheet1").Range("B" & nextCell).Value = "(FCST)"
I just don't see it print in the excel spreadsheet. Here's the relevant code:
EDIT: I changed it to add all my code -
Dim strIDRangeISS As String
Dim strIDRangeFCST As String
Dim iRow As Integer
Dim iCol As Integer
Dim ID_ISS As Long
Dim ID_FCST As Long
Dim nextCell As Integer
Dim iRowISS As Integer
Dim iRowFCST As Integer
Dim wbkFCST As Excel.Workbook
Dim wbkISS As Excel.Workbook
Dim mainWB As Excel.Workbook
Dim varSheetFCST As Excel.Worksheet
Dim varSheetISS As Excel.Worksheet
Dim mainWS As Excel.Worksheet
nextCell = 1
Set wbkFCST = Workbooks.Open("C:\Users\...\Documents\FCST.xlsx")
Set varSheetFCST = wbkFCST.Worksheets("Details")
Set wbkISS = Workbooks.Open(FileName:="C:\Users\...\Documents\ISS.xlsm")
Set varSheetISS = wbkISS.Worksheets("ISS")
Set mainWB = Workbooks.Open(FileName:="C:\Users\...\Documents\Comparison.xlsm")
Set mainWS = mainWB.Worksheets("Sheet1")
strIDRangeISS = "A2:D50"
strIDRangeFCST = "B2:I50"
'varSheetISS = varSheetISS.Range(strIDRangeISS)
'varSheetFCST = varSheetFCST.Range(strIDRangeFCST)
Dim ISSArray As Variant: ISSArray = varSheetISS.Range(strIDRangeISS)
Dim FCSTArray As Variant: FCSTArray = varSheetFCST.Range(strIDRangeFCST)
For iRowISS = LBound(ISSArray, 1) To UBound(ISSArray, 1) 'Goes down ISS' ID column
ID_ISS = ISSArray(iRowISS, 1)
MsgBox ("ID_ISS is " & ID_ISS)
For iRowFCST = LBound(FCSTArray, 1) To UBound(FCSTArray, 1) 'Goes down FCST ID column
ID_FCST = FCSTArray(iRowFCST, 1)
MsgBox ("ID_FCST is " & ID_FCST)
'Compares ISS ID to FCST ID till finds matching
If (ID_ISS = ID_FCST) Then
'If corr symbols aren't same, record ID in Comparison's spreadsheet and go onto next ISS ID
If (ISSArray(iRowISS, 3) <> FCSTArray(iRowFCST, 2)) Or (ISSArray(iRowISS, 4) <> FCSTArray(iRowFCST, 8)) Then
mainWB.Worksheets("Sheet1").Range("A" & nextCell).Value = ID_ISS
'Symbol mismatch
If (ISSArray(iRowISS, 3) <> FCSTArray(iRowFCST, 2)) Then
mainWB.Sheets("Sheet1").Range("B" & nextCell).Value = "Symbol"
End If
'(FCST) mismatch
If (ISSArray(iRowISS, 4) <> FCSTArray(iRowFCST, 8)) Then
mainWB.Sheets("Sheet1").Range("B" & nextCell).Value = "(FCST)"
End If
nextCell = nextCell + 1
End If
Exit For 'If corr symbols are same, go onto next ISS ID
End If
'Reached end of FCST ID's and no match -> record ISS ID
If iRowFCST = 49 Then
Workbooks("Comparison.xlsm").Sheets("Sheet1").Range("A" & nextCell).Value = ID_ISS
Workbooks("Comparison.xlsm").Sheets("Sheet1").Range("B" & nextCell).Value = "No corressponding Issue ID"
nextCell = nextCell + 1
Exit For
End If
Next iRowFCST
Next iRowISS
Related
I am having a issue to auto fill data from another sheet, I am trying to enter "sku" Value in Sheet(Report), then auto fill both "Store name" & "qty" from another Sheet(SOH). However, if the last row of the "store name" (Column A, Report Sheet) = Blank, this Marco will not working properly, otherwise it is working fine. Did I miss something? Any help would be greatly appreciated!!
Sub Fill_Report()
Dim d, s As Long
Dim sQTY As Double
Dim dws, sws As Worksheet
Set dws = ThisWorkbook.Worksheets("Report") 'Destination Sheet
Set sws = ThisWorkbook.Worksheets("SOH") 'Source Sheet
dlr = dws.Cells(Rows.Count, 1).End(xlUp).Row
slr = sws.Cells(Rows.Count, 1).End(xlUp).Row
For d = 2 To dlr
For s = 2 To slr
ssku = sws.Cells(s, "A:A").Value
dsku = dws.Cells(d, "B:B").Value
'Index qty from source
sQTY = Application.IfError(Application.Index(Sheets("SOH").Range("A:Z"), _
Application.Match(ssku, Sheets("Report").Range("B:B"), 0), 2), 0)
'add title
dws.Cells(1, 1).Value = "Sotre Name"
dws.Cells(1, 2).Value = "sku"
dws.Cells(1, 3).Value = "qty"
If dsku = ssku Then
dws.Cells(d, "A").Value = "ABC"
dws.Cells(d, "C").Value = sQTY
Exit For
End If
Next s
Next d
End Sub
Collections and Dictionaries are optimized for fast lookups. Consider using them over Match and Index.
Range("A1").CurrentRegion will select the entire range of contiguous cells.
Sub Fill_Report()
Dim Quantities As New Collection
Set Quantities = getSKUQuantity
Dim Data As Variant
Data = wsReport.Range("A1").CurrentRegion.Columns("B").Offset(1)
Dim r As Long
Dim QTY As Double
For r = r To UBound(Data)
On Error Resume Next
QTY = Quantities(Data(r, 1))
If Err.Number = 0 Then
Data(r, 1) = QTY
Else
Data(r, 1) = ""
End If
On Error GoTo 0
Next
wsReport.Range("A1").CurrentRegion.Columns("C").Offset(1).Value = Data
End Sub
Function getSKUQuantity() As Collection
Dim Data As Variant
Data = wsSOH.Range("A1").CurrentRegion
Dim Quantities As New Collection
Dim r As Long
For r = 2 To UBound(Data)
On Error Resume Next
If Err.Number = 0 Then
Quantities.Add Data(r, 2), CStr(Data(r, 1))
Else
Debug.Print "Duplicate SKU: ", Data(r, 1)
End If
On Error GoTo 0
Next
Set getSKUQuantity = Quantities
End Function
Function wsSOH() As Worksheet
Set wsSOH = ThisWorkbook.Sheets("SOH")
End Function
Function wsReport() As Worksheet
Set wsReport = ThisWorkbook.Sheets("Report")
End Function
I am having problem with the subscript out of range with this line:
datasheet = wbook.Sheets("Month and Year")
I have tried to use On Error Resume but I might have done it wrong.
This code is suppose to establish month and year so that later, I am able to use it when I create a new sheet and refer to the previous one named similarly "Forecast Month Year". afterwards, it looks at 3 columns to validate that it is the row that it wants to copy and paste and then establishes it on the respective sheet.
Sub repeatingrows()
Dim wbook As Workbook
Set wbook = Application.ActiveWorkbook
'CHECKS THE MONTH TO INCREASE THE YEAR
Dim datasheet As Worksheet
datasheet = wbook.Sheets("Month and Year")
Dim m As Integer
Dim y As Integer
Dim t As Integer
For t = 2 To 13
For m = 1 To 13
If m = 13 Then
y = y + 1
m = 1
End If
Next m
m = .Cells(t, 1)
.Cells(t, 1) = .Cells(t, 2)
Next t
'MAKE NEW SHEET AND RENAME IT
Dim oldsheet As Worksheet
Dim newsheet As Worksheet
Set oldsheet = Application.ActiveSheet
oldsheet = Sheets("Forecast " & m & " " & y)
newsheet = Sheets("Forecast " & (m + 1) & " " & y)
Sheets.Add.Name = "Forecast " & (m + 1) & " " & y
'CHECK IF the 3 columns ARE SIMILAIR TO PREVIOUS PAGE
Dim rrow As Integer
For rrow = 3 To 500
If Sheets(3).Cell(rrow, 2) = Sheets(2).Cell(rrow, 2) Then
If Sheets(3).Cell(rrow, 5) = Sheets(2).Cell(rrow, 5) Then
If Sheets(3).Cell(rrow, 6) = Sheets(2).Cell(rrow, 6) Then
With newsheet
oldsheet.Range(oldsheet.Cells(rrow, 16), oldsheet.Cells(rrow, 19)).Copy
.Range(.Cells(b, a), .Cells(99, 51)).PasteSpecial xlPasteValues, xlPasteSpecialOperationAdd
End With '^COPY AND PASTES THE ROW
Else
End If
Else
End If
Else
End If
Next rrow
End Sub
try:
Set datasheet = wbook.Sheets("Month and Year")
and check the spelling of the sheetnameand check that the sheet exists in the proper workbook.and don't use .Cells() without a With
(there may be other errors)
I have written this code to take data from one workbook, put it into an array, then place the data in an empty row in another workbook. It works until it gets to i=25 in the For loop where it adds the hyperlink. The hyperlink is actually correctly added, and functions properly, but when I step through the line it gives me a "Application-Defined or Object-Define Error" even though the line added the hyperlink correctly.
Any help would be greatly appreciated. I've been stuck on this for a few days, and have tried many adjustments.
Private Sub CopyDataToMatrix()
'This macro copies the data from the process sheet & automatically pastes it into
'the matrix.
Dim wb1 As Workbook
Dim wb2 As Workbook
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim Data(1 To 26)
Dim EmptyRow As Range
Dim strSearch As String
Dim rngSearch As Range
Dim rowNum As Integer
Set wb1 = ActiveWorkbook
Set wb2 = Workbooks.Open("***ForPrivacy***")
Set ws1 = wb1.Sheets("ProcessData")
Set ws2 = wb2.Sheets("2016")
'Put all of the data into an array:
Data(1) = ws1.Range("B57").Value
Data(2) = ws1.Range("B3").Value
Data(3) = ws1.Range("B4").Value
Data(4) = ws1.Range("B5").Value
Data(5) = ws1.Range("F7").Value
Data(6) = ws1.Range("B6").Value
Data(7) = ws1.Range("B7").Value
Data(8) = ws1.Range("F8").Value
Data(9) = ws1.Range("B8").Value
Data(10) = ws1.Range("B9").Value
Data(11) = ws1.Range("B10").Value
Data(12) = ws1.Range("F9").Value
Data(13) = ws1.Range("F4").Value
Data(14) = ws1.Range("F5").Value
Data(15) = ws1.Range("F6").Value
Data(16) = ws1.Range("G4").Value
Data(17) = ws1.Range("G5").Value
Data(18) = ws1.Range("G6").Value
Data(19) = ws1.Range("H4").Value
Data(20) = ws1.Range("H5").Value
Data(21) = ws1.Range("H6").Value
Data(22) = ws1.Range("I4").Value
Data(23) = ws1.Range("I5").Value
Data(24) = ws1.Range("I5").Value
Data(25) = Left(wb1.Name, 8)
'IM MATRIX:
'Look to see if the row already exists in IM Matrix with the current file name, and if so overwrite it:
strSearch = Left(wb1.Name, 8)
Set rngSearch = ws2.Range("Y:Y")
If Application.CountIf(rngSearch, strSearch) > 0 Then
rowNum = Application.Match(strSearch, rngSearch, 0)
With ws2
Set EmptyRow = .Cells(rowNum, 1)
For i = LBound(Data) To 24
EmptyRow.Offset(0, i - 1).Value = Application.Index(Data, i)
Next i
For i = 25 To 25
EmptyRow.Offset(0, i - 1).Value = ws2.Hyperlinks.Add(EmptyRow.Offset(0, i - 1), wb1.FullName, , "Click to go to IML file.", Data(i))
Next i
End With
'If the file name isn't already in IM Matrix, then enter data in new row:
Else
With ws2
Set EmptyRow = .Cells(.Rows.Count, 1).End(xlUp).Offset(1)
For i = LBound(Data) To 24
EmptyRow.Offset(0, i - 1).Value = Application.Index(Data, i)
Next i
For i = 25 To 25
**''HERE IS WHERE THE CODE BUGS:**
**EmptyRow.Offset(0, i - 1).Value = ws2.Hyperlinks.Add(EmptyRow.Offset(0, i - 1), wb1.FullName, , "Click to go to IML file.", Data(i))**
Next i
End With
End If
'Close & save IM Matrix file:
wb2.Close SaveChanges:=True
End Sub
Here is the solution that worked with the help of #JMichael:
Private Sub CopyDataToMatrix()
'This macro copies the data from the process sheet & automatically pastes it into
'the matrix.
Dim wb1 As Workbook
Dim wb2 As Workbook
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim Data(1 To 26)
Dim EmptyRow As Range
Dim strSearch As String
Dim rngSearch As Range
Dim rowNum As Integer
Set wb1 = ActiveWorkbook
Set wb2 = Workbooks.Open("***ForPrivacy***")
Set ws1 = wb1.Sheets("ProcessData")
Set ws2 = wb2.Sheets("2016")
'Put all of the data into an array:
Data(1) = ws1.Range("B57").Value
Data(2) = ws1.Range("B3").Value
Data(3) = ws1.Range("B4").Value
Data(4) = ws1.Range("B5").Value
Data(5) = ws1.Range("F7").Value
Data(6) = ws1.Range("B6").Value
Data(7) = ws1.Range("B7").Value
Data(8) = ws1.Range("F8").Value
Data(9) = ws1.Range("B8").Value
Data(10) = ws1.Range("B9").Value
Data(11) = ws1.Range("B10").Value
Data(12) = ws1.Range("F9").Value
Data(13) = ws1.Range("F4").Value
Data(14) = ws1.Range("F5").Value
Data(15) = ws1.Range("F6").Value
Data(16) = ws1.Range("G4").Value
Data(17) = ws1.Range("G5").Value
Data(18) = ws1.Range("G6").Value
Data(19) = ws1.Range("H4").Value
Data(20) = ws1.Range("H5").Value
Data(21) = ws1.Range("H6").Value
Data(22) = ws1.Range("I4").Value
Data(23) = ws1.Range("I5").Value
Data(24) = ws1.Range("I5").Value
Data(25) = Left(wb1.Name, 8)
'IM MATRIX:
'Look to see if the row already exists in IM Matrix with the current file name, and if so overwrite it:
strSearch = Left(wb1.Name, 8)
Set rngSearch = ws2.Range("Y:Y")
If Application.CountIf(rngSearch, strSearch) > 0 Then
rowNum = Application.Match(strSearch, rngSearch, 0)
With ws2
Set EmptyRow = .Cells(rowNum, 1)
For i = LBound(Data) To 24
EmptyRow.Offset(0, i - 1).Value = Application.Index(Data, i)
Next i
ws2.Hyperlinks.Add EmptyRow.Offset(0, 24), wb1.FullName, , "Click to go to IML file.", Data(25)
End With
'If the file name isn't already in IM Matrix, then enter data in new row:
Else
With ws2
Set EmptyRow = .Cells(.Rows.Count, 1).End(xlUp).Offset(1)
For i = LBound(Data) To 24
EmptyRow.Offset(0, i - 1).Value = Application.Index(Data, i)
Next i
ws2.Hyperlinks.Add EmptyRow.Offset(0, 24), wb1.FullName, , "Click to go to IML file.", Data(25)
End With
End If
'Close & save IM Matrix file:
wb2.Close SaveChanges:=True
End Sub
Based on the code that I got when I recorded creating a hyperlink seems like you need to just remove everything before ws2.Hyperlinks.... The hyperlink creation code contains the cell to put the link in, so I think it inherently fills the .Value for the cell.
Make sure to update the code in that covers the case that Application.CountIf(rngSearch, strSearch) > 0 returns as True since it's the trying to do the same thing.
You could also drop the For loop around adding the hyperlink since you're not really looping. You can either just increment i before the hyperlink creation, or just hardcode the values.
I have a slight problem in Excel. I need to sync up the values in the curly braces {} found in column C and put them against the user id in column F. I would like this data to be copied across to a new worksheet in the same workbook. Any ideas how I could accomplish this? You don't have to provide any code but a nudge in the right direction would be great.
E.g. on the Emails sheet
becomes this on a new sheet
In case anyone needs help, this is the solution:
Sub CopyConditional()
Dim wshS As Worksheet
Dim WhichName As String
Set wshS = ActiveWorkbook.Sheets("Emails")
WhichName = "NewSheet"
Const NameCol = "C"
Const FirstRow = 1
Dim LastRow As Long
Dim SrcRow As Long
Dim TrgRow As Long
Dim wshT As Worksheet
Dim cpt As String
Dim user As String
Dim computers() As String
Dim computer As String
On Error Resume Next
Set wshT = Worksheets(WhichName)
If wshT Is Nothing Then
Set wshT = Worksheets.Add(After:=wshS)
wshT.Name = WhichName
End If
On Error GoTo 0
If wshT.Cells(1, NameCol).value = "" Then
TrgRow = 1
Else
TrgRow = wshT.Cells(wshT.Rows.Count, NameCol).End(xlUp).Row + 1
End If
LastRow = wshS.Cells(wshS.Rows.Count, NameCol).End(xlUp).Row
For SrcRow = FirstRow To LastRow
cpt = wshS.Range("C" & SrcRow).value
user = wshS.Range("F" & SrcRow).value
If InStr(cpt, ":") Then
cpt = Mid(cpt, InStr(1, cpt, ":") + 1, Len(cpt))
End If
If InStr(cpt, ";") Then
computers = Split(cpt, ";")
For i = 0 To UBound(computers)
If computers(i) <> "" Then
wshT.Range("A" & TrgRow).value = user
wshT.Range("B" & TrgRow).value = Mid(Left(computers(i), Len(computers(i)) - 1), 2)
TrgRow = TrgRow + 1
End If
Next
Else
computer = cpt
If computer <> "" Then
wshT.Range("A" & TrgRow).value = user
wshT.Range("B" & TrgRow).value = Mid(Left(computer, Len(computer) - 1), 2)
TrgRow = TrgRow + 1
End If
End If
Next SrcRow
End Sub
You didn't ask a question. Basically what you would do is
loop through the values in column F
for each value, get the value in column C
loop through all braced values in column C
let braceValue = parse column C searching for {value}
create a row in new worksheet with column F value, braceValue
I am trying to copy paste a row of values from one sheet to another but keep coming up with the run-time error 1004: Application-defined or object-defined error.
the error is in the first line of the two below and I do not know where I am going wrong.
Set copyRange = Worksheets("Sheet2").range(A & i + 1 & CA & i + 1)
copyRange.Copy Destination:=Cells(countD, 2)
the code needs to copy a line at a time and paste it into the default sheet.
Edit
full code
Dim List1 As range
Dim List2 As range
Dim lastRow As Integer
Dim countD As Integer
Dim found As Boolean
Dim copyRange As range
Set List1 = ThisWorkbook.Sheets("Sheet1").range("H2:H600")
Set List2 = ThisWorkbook.Sheets("Sheet2").range("I2:I600")
countD = 2
lastRow = Application.CountA(ThisWorkbook.Sheets("Sheet2").range("C:C"))
For i = lastRow To 2 Step -1
found = False
value1 = List1.Item(i, 1)
For Each value2 In List2
If value1 = value2 Then
found = True
Exit For
End If
Next
If found = False Then
Set copyRange = Sheets("Sheet1").range("A" & i + 1 & "CA" & i + 1)
copyRange.Copy Destination:=Cells(countD, 2)
Sheets("Discrepancies").Cells(countD, 1) = "name not found"
ThisWorkbook.Sheets("Sheet1").Cells(i + 1, 1).EntireRow.Delete
Cells(countD, 8).Interior.ColorIndex = 3
countD = countD + 1
End If
Next
Exactly as Vasim's comment mentions - with the addition of a colon : in front of the CA
Sub copyRangeOver()
Dim i As Integer
i = 6
Dim copyRange As Range
Set copyRange = ThisWorkbook.Worksheets("Sheet2").Range("A" & i + 1 & ":CA" & i + 1)
Dim countD As Integer
countD = 10
copyRange.Copy Destination:=Cells(countD, 2)
End Sub