I Hvae the following code:
Public Sub CiscoPrimeReport111()
Dim rowCounter As Long
Dim colCounter As Long
Dim throughputAP As Long
throughputAP = 2
rowCounter = 8
colCounter = 1
MsgBox ("Please do the following before pressing the OK BUtton on this Popup Window!!:" & vbNewLine & vbNewLine & _
"1. Open the CISCO PRIME AP Report you want to use" & vbNewLine & _
"2. Select all the data (Ctrl + A)" & vbNewLine & _
"3. Copy ALL the content (Ctrl + C)" & vbNewLine & _
"4. NOW YOU CAN PRESS THE OK BUTTON!")
Application.DisplayAlerts = False
Call createCiscoSheet
With ThisWorkbook.Sheets("Cisco Raw")
.Range("A1").PasteSpecial (xlPasteValues)
With ThisWorkbook.ActiveSheet.Rows(rowCounter)
Do Until Cells(rowCounter, colCounter).Value = "AP Statistics Summary"
ThisWorkbook.Sheets("Throughput Per AP").Rows(throughputAP).Resize(1, .Columns.Count - 1).Offset(0, 1).Value = _
.Rows(throughputAP).Value '.Resize(1, .Columns.Count - 1).Value
throughputAP = throughputAP + 1
rowCounter = rowCounter + 1
Loop
End With
End With
End Sub
the code runs well and the'Do Until' loop runs well too but it is not stoping when the following condition is met:
Do Until Cells(rowCounter, colCounter).Value = "AP Statistics Summary"
it just keeps on looping until the end of the source sheet.
any ideas why? i am a noob at this so any help is appreciate it!
Related
I have the following code, that basically copies databases from some files in a folder and pastes in my workbook.
It is supposed to clean everything before starting, and it does when I run from console, hitting F8 and going through it, but when I click the button to which I have assigned the Macro, it does not clean the old base before getting the new ones, then I get old data and then new data below it.
Do you know what can cause it?
Thank you!
Sub Atualizar_B_Un_Time()
Application.ScreenUpdating = False 'speed up macro execution
Application.EnableEvents = False 'turn off other macros for now
Application.DisplayAlerts = False 'turn off system messages for now
Dim base_5 As Workbook
Dim plan_5 As Worksheet
Dim aux As String
Dim caminho As String
Dim nome_arquivo_5 As String
Dim destino_5 As Worksheet
Dim dia As String
Set destino_5 = ThisWorkbook.Worksheets("B_Un_Time")
caminho = Application.ActiveWorkbook.Path
nome_arquivo_5 = Dir(caminho & "\IC_Reports_AgentUnavailableTime*.xlsx")
destino_5.Range("H2:L" & Cells(Rows.Count, "I").End(xlUp).Row).UnMerge
destino_5.Range("F2:F" & Cells(Rows.Count, "F").End(xlUp).Row).ClearContents
destino_5.Range("H2:L" & Cells(Rows.Count, "I").End(xlUp).Row).ClearContents
Do While nome_arquivo_5 <> ""
aux = caminho & "\" & nome_arquivo_5
Set base_5 = Workbooks.Open(aux, Local:=True)
Set plan_5 = base_5.Sheets(1)
dia = Mid(nome_arquivo_5, InStr(nome_arquivo_5, "-") + 1, 2)
plan_5.Range("A2:E" & plan_5.Cells(Rows.Count, "B").End(xlUp).Row).Copy _
Destination:=destino_5.Range("H" & (destino_5.Cells(Rows.Count, "I").End(xlUp).Row + 1))
destino_5.Range("F" & (destino_5.Cells(Rows.Count, "F").End(xlUp).Row + 1) & ":" & "F" & _
(destino_5.Cells(Rows.Count, "I").End(xlUp).Row)).Value = Format(Now, "mm/") & dia & Format(Now, "/yyyy")
base_5.Close savechanges:=False
nome_arquivo_5 = Dir
Loop
If IsEmpty(destino_5.Range("A" & destino_5.Cells(Rows.Count, "I").End(xlUp).Row)) Then
destino_5.Range("A2:E2").Copy Destination:=destino_5.Range("A" & (destino_5.Cells(Rows.Count, "A").End(xlUp).Row + 1) _
& ":" & "E" & destino_5.Cells(Rows.Count, "I").End(xlUp).Row)
destino_5.Range("G2").Copy Destination:=destino_5.Range("G" & (destino_5.Cells(Rows.Count, "G").End(xlUp).Row + 1) & ":" & _
"G" & destino_5.Cells(Rows.Count, "I").End(xlUp).Row)
ElseIf Not IsEmpty(destino_5.Range("A" & (destino_5.Cells(Rows.Count, "I").End(xlUp).Row + 1))) Then
destino_5.Rows((destino_5.Cells(Rows.Count, "I").End(xlUp).Row + 1) & ":" & destino_5.Cells(Rows.Count, "A") _
.End(xlUp).Row).EntireRow.Delete
End If
destino_5.Cells.Font.Name = "Calibri"
destino_5.Cells.Font.Size = 8
destino_5.Rows.RowHeight = 11.25
Application.DisplayAlerts = True 'turn system alerts back on
Application.EnableEvents = True 'turn other macros back on
Application.ScreenUpdating = True 'refreshes the screen
End Sub
It's probably because you haven't added a sheet references everywhere. and hence are referencing the active sheet. Try amending that section thus (note the dots):
With destino_5
.Range("H2:L" & .Cells(.Rows.Count, "I").End(xlUp).Row).UnMerge
.Range("F2:F" & .Cells(.Rows.Count, "F").End(xlUp).Row).ClearContents
.Range("H2:L" & .Cells(.Rows.Count, "I").End(xlUp).Row).ClearContents
End With
I have a loop looking for text in a column (that is working) and I want to post the result in a MsgBox, but when I use the msgbox in or outside the loop I will get a msgbox for every result found or only one msgbox with one result. What I would like is to make it post every result in 1 msgbox with a line break after each result.
I know the first code is not the prettiest or best way to go around finding duplicates and I should use an array for it, but it's the only way I got it to work.
The first code finding duplicates (not relevant for the question):
Dim lastRow As Long
Dim i As Long
Dim ws As Worksheet
Dim txt As String
Set ws = Sheets("Player List")
Dim matchFoundIndex As Long
Dim iCntr As Long
lastRow = Range("A201").End(xlUp).Row
For iCntr = 1 To lastRow
If Cells(iCntr, 1) <> "" Then
matchFoundIndex = WorksheetFunction.Match(Cells(iCntr, 1), Range("A1:A" &
lastRow), 0)
If iCntr <> matchFoundIndex Then
Cells(iCntr, 2) = "Duplicate"
End If
End If
Next
The loop with the msgbox:
For i = 2 To 201
If ws.Range("B" & i).Value = "Duplicate" Then
txt = "Duplicates found for" + " " + ws.Range("A" & i).Value + " " + "in" +
ws.Range("L" & i).Value + vbNewLine
End If
Next i
MsgBox txt
You need to persist the old value of txt.
txt = txt & "Duplicates found for" & " " & ws.Range("A" & i).Value & " " & "in" & ws.Range("L" & i).Value & vbNewLine
I am attempting to write some VBA that will accomplish
if row O is not null then copy all data to new row, then in current row clear columns I, J, K, L, M, N
in the newly inserted row clear columns O
The caveat I am not sure to account for is - throws a
Type mismatch error
Here is the syntax that I am trying to work with
Sub BlueBell()
Application.ScreenUpdating = False
Dim i As Long, y
ReDim y(2 To Range("A" & Rows.Count).End(3).Row)
For i = UBound(y) To LBound(y) Step -1
If Cells(i, "O") Then
If Cells(i, "I") = "" And Cells(i, "K") = "" And Cells(i, "M") = "" Then
GoTo DoNothing
Else
Rows(i).Copy
Cells(i, "A").Insert
Range("I" & i & ":J" & i & ":K" & i & ":L" & i & ":M" & i & ":N" & i & ":O" & i + 1).ClearContents
GoTo DoNothing
End If
End If
DoNothing:
Next i
End Sub
Apart from your error with using a string as a boolean expression, there are several things that can be changed in your code:
Sub BlueBell()
Application.ScreenUpdating = False
Dim i As Long ', y() As Variant
'ReDim y(2 To Range("A" & Rows.Count).End(3).Row) 'Why use an array?
For i = Range("A" & Rows.Count).End(3).Row To 2 Step -1
If Not IsEmpty(Cells(i, "O").Value) Then
'Avoid the use of GoTo
If Cells(i, "I").Value <> "" Or _
Cells(i, "K").Value <> "" Or _
Cells(i, "M").Value <> "" Then
Rows(i).Copy
Cells(i, "A").Insert
'Don't use a "Ix:Jx:Kx:Lx:Mx:Nx:Ox+1" range - it will lead to problems
'because even really experienced users don't understand what it does
Range("I" & i & ":N" & i).ClearContents
Range("O" & i + 1).ClearContents
End If
End If
Next i
'It's a good habit to reset anything that you disabled at the start of your code
Application.ScreenUpdating = True
End Sub
I have a question that how to pull the questions one after the other if the student clicks on next button.
Here I have two excel workbook and one is master workbook and the other one is for the tool designed for giving test (student will view this).
Sub Button1_Click()
Dim s(6 To 100) As String`enter code here`
Dim stname As String
Dim neWb As Workbook
Dim mypath As String
Dim u As String
u = "_xlsx"
Application.DisplayAlerts = False
For i = 6 To 100
s(i) = Range("E" & i).Value
stname = s(i) & "" & u
If s(i) = "" Then
ActiveWorkbook.Open = False
End If
On Error GoTo jamun:
mypath = Range("B1").Value & "\" & stname
Set neWb =Workbooks.Open("anypath\nanoo.xls")'It can be c drive or any other drive in the system
neWb.SaveAs filename:=mypath
neWb.Close
Range("B" & i).Value = mypath & "_assigning..."
Application.Wait Now + TimeValue("00:00:02")
Range("F" & i).Value = "Done"
Range("B" & i).Value = mypath & "_assigned"
Application.Wait Now + TimeValue("00:00:01")
Range("B" & i).Select
'Adding hyper link to all the lines that shows the status to whom it has been assigned and to whom it is yet to assign
ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:="mypath", TextToDisplay:=Range("B" & i).Value
Range("B" & i).Select
Selection.Hyperlinks(1).Address = Range("B1").Value
Next
MsgBox "Test assigned successfully"
Exit Sub
jamun:
MsgBox "Test assigned successfully"
End Sub
I am exporting data from one workbook to another workbook to T13:Tlastrow
This data, from column F in my workbook where I run this macro, I want to be put into {nyckel="TEXT HERE";} in column T in the "new" workbook, starting from row 13 (T13).
I am stuck here. So would really appreciate some help/solution. Thanks!
Sub CopyData()
Dim wkbCurrent As Workbook, wkbNew As Workbook
Set wkbCurrent = ActiveWorkbook
Dim valg, c, LastCell As Range
Set valg = Selection
Dim wkbPath, wkbFileName, lastrow As String
Dim LastRowInput As Long
Dim lrow, rwCount, lastrow2, LastRowInput2 As Long
Application.ScreenUpdating = False
' If nothing is selected in column A
If Selection.Columns(1).Column = 1 Then
wkbPath = ActiveWorkbook.Path & "\"
wkbFileName = Dir(wkbPath & "CIF LISTEN.xlsm")
Set wkbNew = Workbooks.Open(wkbPath & "CIF LISTEN.xlsm")
'Application.Run ("'C:\Users\niclas.madsen\Desktop\TEST\CIF LISTEN.xlsm'!DelLastRowData")
LastRowInput = Cells(Rows.count, "A").End(xlDown).Row
For Each c In valg.Cells
lrow = wkbNew.Worksheets(1).Range("B1").Offset(wkbNew.Worksheets(1).Rows.count - 1, 0).End(xlUp).Row + 1
lastrow2 = Range("A" & Rows.count).End(xlUp).Row
lastrow3 = Range("T" & Rows.count).End(xlUp).Row
wkbCurrent.ActiveSheet.Range("E" & c.Row).Copy Destination:=wkbNew.Worksheets(1).Range("A" & lrow)
wkbCurrent.ActiveSheet.Range("A" & c.Row).Copy Destination:=wkbNew.Worksheets(1).Range("B" & lrow)
wkbCurrent.ActiveSheet.Range("F" & c.Row).Copy Destination:=wkbNew.Worksheets(1).Range("T" & lrow)
' Standard inputs
wkbNew.Worksheets(1).Range("D13:D" & lastrow2).Value = "Ange referens och period"
wkbNew.Worksheets(1).Range("E13:E" & lastrow2).Value = "99999002"
wkbNew.Worksheets(1).Range("G13:G" & lastrow2).Value = "EA"
wkbNew.Worksheets(1).Range("H13:H" & lastrow2).Value = "2"
wkbNew.Worksheets(1).Range("M13:M" & lastrow2).Value = "SEK"
wkbNew.Worksheets(1).Range("N13:N" & lastrow2).Value = "sv_SE"
wkbNew.Worksheets(1).Range("P13:P" & lastrow2).Value = "TRUE"
wkbNew.Worksheets(1).Range("Q13:Q" & lastrow2).Value = "TRUE"
wkbNew.Worksheets(1).Range("S13:S" & lastrow2).Value = "Catalog_extensions"
'wkbNew.Worksheets(1).Range("T" & lastrow3).Value = "{Nyckelord=" & wkbNew.Worksheets(1).Range("T" & lastrow3).Value & ";}"
Next
' Trying to get this to work
LastRowInput2 = wkbNew.Worksheets(1).Range("T" & wkbNew.Sheets("Sheet1").UsedRange.Rows.count + 1).End(xlUp).Row
For i = 0 To LastRowInput2 - 13
wkbNew.Worksheets(1).Range("T" & 13 + i).Value = "{Nyckelord=" & wkbNew.Worksheets(1).Range("T" & 13 + i).Value & ";}"
Next i
' END HERE
' wkbNew.Close False
' Find the number of rows that is copied over
wkbCurrent.ActiveSheet.Activate
areaCount = Selection.Areas.count
If areaCount <= 1 Then
MsgBox "The selection contains " & Selection.Rows.count & " suppliers."
' Write it in A10 in CIF LISTEN
wkbNew.Worksheets(1).Range("A10").Value = "COMMENTS: " & Selection.Rows.count & " Suppliers Added"
Else
i = 1
For Each A In Selection.Areas
'MsgBox "Area " & I & " of the selection contains " & _
a.Rows.count & " rows."
i = i + 1
rwCount = rwCount + A.Rows.count
Next A
MsgBox "The selection contains " & rwCount & " suppliers."
' Write it in A10 in CIF LISTEN
wkbNew.Worksheets(1).Range("A10").Value = "COMMENTS: " & rwCount & " Suppliers Added"
End If
wkbNew.Worksheets(1).Activate
Application.ScreenUpdating = True
Else
MsgBox "Please select cell(s) in column A", vbCritical, "Error"
Exit Sub
End If
End Sub
OK Try
wkbNew.Worksheets(1).Range("T" & lrow).Value = "{Nyckelord=" & wkbCurrent.ActiveSheet.Range("F" & c.Row).Value & "}"
Instead of your line:
wkbCurrent.ActiveSheet.Range("F" & c.Row).Copy Destination:=wkbNew.Worksheets(1).Range("T" & lrow)
And remove the whole block marked 'Trying to get this to work
If the code is doing the right action but on the wrong cells, then the problem is in the start and end of the For loop. Your For Loop is going from row '13 + i' where i = 0 (so row 13), to row 13 + LastRowInput2 - 13 (so LastRowInput2). This seems right to me, so the problem must be with the value in LastRowInput2.
You need to correct this line:
LastRowInput2 = wkbNew.Worksheets(1).Range("T" & wkbNew.Sheets("Sheet1").UsedRange.Rows.count + 1).End(xlUp).Row
So that is gives you the correct last row input in your data. There are several approaches to finding the end of data depending on whether there may be blank cells in the middle and other factors. This may be one option:
LastRowInput2 = wkbNew.Worksheets(1).Range("T65000").End(xlUp).Row
Be sure to step through the code and verify that LastRowInput2 is set to the value you expect and then this should work.