This may sound like an easy question, but I couldn't find a simple way to write the output of a collection ( just a column ) to a worksheet.
Collection gives the correct answers on debug.print and all I want to do that simply put that output on a worksheet, and then clear the output.
This is my main code for collection;
Worksheets(Ders_Sheet_Adi).Visible = True
Dim LastRowXL_1, LastRowXL_2, LastRowXL_3 As Long
Dim uniques As Collection
Dim Source_XL As Range
LastRowXL_1 = Worksheets(Ders_Sheet_Adi).Cells(Rows.Count, 40).End(xlUp).Row
LastRowXL_2 = Worksheets(Ders_Sheet_Adi).Cells(Rows.Count, 41).End(xlUp).Row
LastRowXL_2_Q = LastRowXL_2 + 1
LastRowXL_3 = Worksheets(Ders_Sheet_Adi).Cells(Rows.Count, 42).End(xlUp).Row
LastRowXL_3_Q = LastRowXL_3 + 1
LastRowXL_4_Q = LastRowXL_3_Q + LastRowXL_1 + 1
XL_Main = WorksheetFunction.Max(LastRowXL_1, LastRowXL_2, LastRowXL_3)
Set Source_XL = Worksheets(Ders_Sheet_Adi).Range("AN2:AP" & XL_Main & "")
Set uniques = GetUniqueValues(Source_XL.Value)
I found a way, just by simply putting a For array after the collection.
I Put these codes after the collection and voila, it works right now;
Dim it_XL
Worksheets(Ders_Sheet_Adi).Range("AN1:AP1100").Select
Selection.ClearContents
it_XLQ = 1
For Each it_XL In uniques
If it_XLQ = 1 Then it_XLQ_M = 100 Else it_XLQ_M = it_XLQ - 1
Worksheets(Ders_Sheet_Adi).Range("AP" & it_XLQ & "") = it_XL
If Worksheets(Ders_Sheet_Adi).Range("AP" & it_XLQ & "") = Worksheets(Ders_Sheet_Adi).Range("AP" & it_XLQ_M & "") Then
Worksheets(Ders_Sheet_Adi).Range("AP" & it_XLQ & "").Delete
GoTo Son2
Else: GoTo Son3
End If
Son3:
it_XLQ = it_XLQ + 1
Next
Worksheets(Ders_Sheet_Adi).Range("AP1:AP20").Copy
Worksheets(Ders_Sheet_Adi).Range("AQ1:AQ20").PasteSpecial Paste:=xlPasteValues
Son2:
LastRow_END = Worksheets(Ders_Sheet_Adi).Cells(Rows.Count, 43).End(xlUp).Row
Related
I am relatively new to VBA.
I have 2 files: (1) Master file (2) Monthly Stats file. I am trying to loop through a column in the Master File to see if it corresponds with the Monthly file. If it matches, then extract the name from Master file. However, there are a lot of N/A inputs in the column, and I only want to loop through rows that start with the string "A". As I already have a nested loop, I cannot type another Next A. Here is my code:
Sub SummaryData()
Dim CustCode As String
Dim CustName As String
Dim wkb As Workbook
Dim Count As Integer
Workbooks.Open Filename:=Sh_Source.Range("HKS").Value
Set wkb = Workbooks("DataHK.xlsx")
For A = 2 To Sh_Main.Range("E" & Rows.Count).End(xlUp).Row
If Left(Range("E" & A).Value, 1) = "A" Then
CustCode = Sh_Main.Range("E" & A).Value
Else
'Not sure what to put'
Count = 0
CustName = ""
For b = 2 To wkb.Sheets("Data").Range("B" & Rows.Count).End(xlUp).Row
X = wkb.Sheets("Data").Range("C" & b).Value
If CustCode = X Then
CustName = Sh_Main.Range("F" & A).Value
Count = Count + 1
Else
End If
Next b
Sh_Body.Range("A" & A).Value = CustCode
Sh_Body.Range("B" & A).Value = CustName
Sh_Body.Range("C" & A).Value = Count
Next A
wkb.Close savechanges:=False
End Sub
Any help would be greatly appreciated as I am new to this, thank you!
If all you want to do is skip the rest of the current iteration of the loop, you could use goto. I know people dislike it, but it can be simpler than other solutions. In this case, put skip: right above the Next A line, and then in your else condition put goto skip where you have 'Not sure what to put' and then close your if statement, like this:
If Left(Range("E" & A).Value, 1) = "A" Then
CustCode = Sh_Main.Range("E" & A).Value
Else
Goto skip
End if
so that the whole code would be
Sub SummaryData()
Dim CustCode As String
Dim CustName As String
Dim wkb As Workbook
Dim Count As Integer
Workbooks.Open Filename:=Sh_Source.Range("HKS").Value
Set wkb = Workbooks("DataHK.xlsx")
For A = 2 To Sh_Main.Range("E" & Rows.Count).End(xlUp).Row
If Left(Range("E" & A).Value, 1) = "A" Then
CustCode = Sh_Main.Range("E" & A).Value
Else
Goto skip
End If
Count = 0
CustName = ""
For b = 2 To wkb.Sheets("Data").Range("B" & Rows.Count).End(xlUp).Row
X = wkb.Sheets("Data").Range("C" & b).Value
If CustCode = X Then
CustName = Sh_Main.Range("F" & A).Value
Count = Count + 1
Else
End If
Next b
Sh_Body.Range("A" & A).Value = CustCode
Sh_Body.Range("B" & A).Value = CustName
Sh_Body.Range("C" & A).Value = Count
skip:
Next A
wkb.Close savechanges:=False
End Sub
Generally people avoid goto (for some good reasons and some bad ones), but I do think that it can be useful and I don't think it's inherently bad. However, most people in your case would put the entire block inside the if statement, like this:
Sub SummaryData()
Dim CustCode As String
Dim CustName As String
Dim wkb As Workbook
Dim Count As Integer
Workbooks.Open Filename:=Sh_Source.Range("HKS").Value
Set wkb = Workbooks("DataHK.xlsx")
For A = 2 To Sh_Main.Range("E" & Rows.Count).End(xlUp).Row
If Left(Range("E" & A).Value, 1) = "A" Then
CustCode = Sh_Main.Range("E" & A).Value
Count = 0
CustName = ""
For b = 2 To wkb.Sheets("Data").Range("B" & Rows.Count).End(xlUp).Row
X = wkb.Sheets("Data").Range("C" & b).Value
If CustCode = X Then
CustName = Sh_Main.Range("F" & A).Value
Count = Count + 1
End If
Next b
Sh_Body.Range("A" & A).Value = CustCode
Sh_Body.Range("B" & A).Value = CustName
Sh_Body.Range("C" & A).Value = Count
End If
Next A
wkb.Close savechanges:=False
End Sub
And then the code inside the if block will only execute if the condition is met and there's no need to try to skip the rest of the for loop.
I will note that some of your variables don't seem* to refer to anything, particularly the sheet? variables: Sh_Source, Sh_Main, and Sh_Body. Without providing a reference for those, this code will fail.
it's possible they are defined outside of the sub you have provided
I have a code that can generate page number on cells.
But I want it apply to mutiple cells in one time instead of single cells.
Sub pagenumber()
'updateby Extendoffice 20160506
Dim xVPC As Integer
Dim xHPC As Integer
Dim xVPB As VPageBreak
Dim xHPB As HPageBreak
Dim xNumPage As Integer
xHPC = 1
xVPC = 1
If ActiveSheet.PageSetup.Order = xlDownThenOver Then
xHPC = ActiveSheet.HPageBreaks.Count + 1
Else
xVPC = ActiveSheet.VPageBreaks.Count + 1
End If
xNumPage = 1
For Each xVPB In ActiveSheet.VPageBreaks
If xVPB.Location.Column > ActiveCell.Column Then Exit For
xNumPage = xNumPage + xHPC
Next
For Each xHPB In ActiveSheet.HPageBreaks
If xHPB.Location.Row > ActiveCell.Row Then Exit For
xNumPage = xNumPage + xVPC
Next
ActiveCell = "Page " & xNumPage & " of " & Application.ExecuteExcel4Macro("GET.DOCUMENT(50)")
End Sub
What can i do for this? Is it also possible for apply the code to highlighted cells?
At the end write this:
Range("A1:B10")="Page "&xNumPage&" of "& Application.ExecuteExcel4Macro("GET.DOCUMENT(50)")
Instead of:
ActiveCell = "Page "&xNumPage& " of " & Application.ExecuteExcel4Macro("GET.DOCUMENT(50)")
Making sure that Range("A1:B10") is the range to which you want to apply the numbers.
How to avoid using Select in Excel VBA
I currently have a macro which goes through a column on my master spreadsheet, then exports all the rows where the value input at the start matches the value in the column. It then saves the new worksheet as the value. Here is the code I currently have:
Option Explicit
Public Const l_HeaderRow As Long = 2 'The header row of the data sheet
Public Const l_DistanceCol As Long = 5 'The column containing the distance values
Public Sub ExportDistance()
Dim ws_Data As Worksheet, wb_Export As Workbook, ws_Export As Worksheet
Dim l_InputRow As Long, l_OutputRow As Long
Dim l_LastCol As Long
Dim l_NumberOfMatches As Long
Dim s_Distance As String, l_Distance As Long
Dim s_ExportPath As String, s_ExportFile As String, s_PathDelimiter As String
Set ws_Data = ActiveSheet
s_Distance = InputBox("Enter Distance to Export to New File", "Enter Distance")
If s_Distance = "" Then Exit Sub
l_Distance = CLng(s_Distance)
l_NumberOfMatches = WorksheetFunction.Match(l_Distance, ws_Data.Columns(5), 0)
If l_NumberOfMatches <= 0 Then Exit Sub
'Application.ScreenUpdating = False
'Application.Calculation = xlCalculationManual
Application.DisplayAlerts = False
On Error Resume Next
Call Application.Workbooks.Add
Set wb_Export = Application.Workbooks(Application.Workbooks.Count)
Set ws_Export = wb_Export.Worksheets(1)
Call wb_Export.Worksheets("Sheet2").Delete
Call wb_Export.Worksheets("Sheet3").Delete
Application.DisplayAlerts = True
ws_Export.Name = GetNextSheetname(ws_Data.Name & "-" & s_Distance, wb_Export)
Call ws_Data.Rows(1).Resize(l_HeaderRow).Copy
Call ws_Export.Rows(1).Resize(l_HeaderRow).Select
Call ws_Export.Paste
l_OutputRow = l_HeaderRow + 1
l_LastCol = ws_Data.UsedRange.Columns.Count
For l_InputRow = l_HeaderRow + 1 To ws_Data.UsedRange.Rows.Count
If ws_Data.Cells(l_InputRow, l_DistanceCol).Value = l_Distance Then
Call ws_Data.Range(ws_Data.Cells(l_InputRow, 1), ws_Data.Cells(l_InputRow, l_LastCol)).Copy
Call ws_Export.Rows(l_OutputRow).Select
Call ws_Export.Paste
l_OutputRow = l_OutputRow + 1
ElseIf ws_Data.Cells(l_InputRow, l_DistanceCol).Value = l_Distance Then
Call ws_Data.Range(ws_Data.Cells(l_InputRow, 1), ws_Data.Cells(l_InputRow, l_LastCol)).Copy
Call ws_Export.Rows(l_OutputRow).Select
Call ws_Export.Paste
l_OutputRow = l_OutputRow + 1
End If
Next l_InputRow
s_ExportPath = ThisWorkbook.Path
s_PathDelimiter = Application.PathSeparator
If Right(s_ExportPath, 1) <> s_PathDelimiter Then s_ExportPath = s_ExportPath & s_PathDelimiter
s_ExportPath = s_ExportPath & "Output" & s_PathDelimiter
If Dir(s_ExportPath) = Empty Then
Call MkDir(s_ExportPath)
End If
Select Case Application.DefaultSaveFormat
Case xlOpenXMLWorkbook
s_ExportFile = s_Distance & ".xlsx"
Case xlOpenXMLWorkbookMacroEnabled
s_ExportFile = s_Distance & ".xlsm"
Case xlExcel12
s_ExportFile = s_Distance & ".xlsb"
Case xlExcel8
s_ExportFile = s_Distance & ".xls"
Case xlCSV
s_ExportFile = s_Distance & ".csv"
Case Else
s_ExportFile = s_Distance
End Select
Call wb_Export.SaveAs(Filename:=s_ExportPath & s_ExportFile, FileFormat:=Application.DefaultSaveFormat)
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
Public Function GetNextSheetname(s_Name As String, Optional wb_Book As Workbook) As String
Dim l_FIndex As Long
Dim s_Target As String
If wb_Book Is Nothing Then Set wb_Book = ActiveWorkbook
s_Name = Left(s_Name, 31)
If IsValidSheet(wb_Book, s_Name) Then
l_FIndex = 1
s_Target = Left(s_Name, 27) & " (" & l_FIndex & ")"
Do While IsValidSheet(wb_Book, s_Target)
l_FIndex = l_FIndex + 1
If l_FIndex < 10 Then
s_Target = Left(s_Name, 27) & " (" & l_FIndex & ")"
ElseIf l_FIndex < 100 Then
s_Target = Left(s_Name, 26) & " (" & l_FIndex & ")"
ElseIf l_FIndex < 1000 Then
s_Target = Left(s_Name, 25) & " (" & l_FIndex & ")"
End If
Loop
GetNextSheetname = s_Target
Else
GetNextSheetname = s_Name
End If
End Function
Public Function IsValidSheet(wbSearchBook As Workbook, v_TestIndex As Variant) As Boolean
Dim v_Index As Variant
On Error GoTo ExitLine
v_Index = wbSearchBook.Worksheets(v_TestIndex).Name
IsValidSheet = True
Exit Function
ExitLine:
IsValidSheet = False
End Function
Please will you help me make this loop through a list of values, rather than my having manually to run the macro each time and input the value myself?
Download this example here.
This is a simple example of how to loop through one range and loop through another range to find the values.
It loops through Column D and then loops through column A, when it finds a match it does something, so basically Column D has taken the place of your inputbox.
run the macro
The code
Sub DblLoop()
Dim aLp As Range 'column A
Dim dLp As Range, dRw As Long 'column D
Dim d As Range, a As Range
Set aLp = Columns("A:A").SpecialCells(xlCellTypeConstants, 23)
dRw = Cells(Rows.Count, "D").End(xlUp).Row
Set dLp = Range("D2:D" & dRw)
'start the loop
'loops through column D and finds value
'in column A, and does something with it
For Each d In dLp.Cells 'loops through column D
For Each a In aLp.Cells 'loops through column A
If d = a Then
'When a match, then do something
'this is where your actual code would go
Range("A" & a.Row & ":B" & a.Row).Copy Cells(Rows.Count, "F").End(xlUp).Offset(1)
End If
Next a 'keeps going through column A
Next d 'next item in column D
End Sub
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 as seen below.
E.g. on the Emails sheet
becomes this on a new sheet
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
I managed to resolve it with the above code but there are 3 niggling issues:
1) The first curly brace is always copied, how do I omit this so something like {Computer1 looks like Computer 1
2) Where there are two computers in a row, then the output looks something like this:
when it should really be split into two different rows i.e.
User 1 | Computer 1
User 1 | Computer 2
3) If there is text after the last curly brace with text in it e.g. {Computer1};{Computer2};Request submitted then that text is added as a new row, I don't want this, I want it to be omitted e.g.
should just be:
User 1 | Computer 1
User 1 | Computer 2
How do I go about rectifying these issues?
Try this:
Sub Collapse()
Dim uRng As Range, cel As Range
Dim comps As Variant, comp As Variant, r As Variant, v As Variant
Dim d As Dictionary '~~> Early bind, for Late bind use commented line
'Dim d As Object
Dim a As String
With Sheet1 '~~> Sheet that contains your data
Set uRng = .Range("F1", .Range("F" & .Rows.Count).End(xlUp))
End With
Set d = CreateObject("Scripting.Dictionary")
With d
For Each cel In uRng
a = Replace(cel.Offset(0, -3), "{", "}")
comps = Split(a, "}")
Debug.Print UBound(comps)
For Each comp In comps
If InStr(comp, "Computer") <> 0 _
And Len(Trim(comp)) <= 10 Then '~~> I assumed max Comp# is 99
If Not .Exists(cel) Then
.Add cel, comp
Else
If IsArray(.Item(cel)) Then
r = .Item(cel)
ReDim Preserve r(UBound(r) + 1)
r(UBound(r)) = comp
.Item(cel) = r
Else
r = Array(.Item(cel), comp)
.Item(cel) = r
End If
End If
End If
Next
Next
End With
For Each v In d.Keys
With Sheet2 '~~> sheet you want to write your data to
If IsArray(d.Item(v)) Then
.Range("A" & .Rows.Count).End(xlUp).Offset(1, 0) _
.Resize(UBound(d.Item(v)) + 1) = v
.Range("B" & .Rows.Count).End(xlUp).Offset(1, 0) _
.Resize(UBound(d.Item(v)) + 1) = Application.Transpose(d.Item(v))
Else
.Range("A" & .Rows.Count).End(xlUp).Offset(1, 0) = v
.Range("B" & .Rows.Count).End(xlUp).Offset(1, 0) = d.Item(v)
End If
End With
Next
Set d = Nothing
End Sub
Above code uses Replace and Split Function to pass your string to array.
a = Replace(cel.Offset(0, -3), "{", "}") '~~> standardize delimiter
comps = Split(a, "}") '~~> split using standard delimiter
Then information are passed to dictionary object using User as key and computers as items.
We filter the items passed to dictionary using Instr and Len Function
If InStr(comp, "Computer") <> 0 _
And Len(Trim(comp)) <= 10 Then
As I've commented, I assumed your max computer number is 99.
Else change 10 to whatever length you need to check.
Finally we return the dictionary information to the target worksheet.
Note: You need to add reference to Microsoft Scripting Runtime if you prefer early bind
Result: I tried it on a small sample data patterned on how I see it in you SS.
So assuming you have this data in Sheet1:
Will output data in Sheet2 like this:
I use a custom parse function for this type of operation:
Sub CopyConditional()
' some detail left out
Dim iRow&, Usern$, Computer$, Computers$
For iRow = ' firstrow To lastrow
Usern = Sheets("Emails").Cells(iRow, "F")
Computers = Sheets("Emails").Cells(iRow, "C")
Do
Computer = zParse(Computers) ' gets one computer
If Computer = "" Then Exit Do
' Store Computer and Usern
Loop
Next iRow
End Sub
Function zParse$(Haystack$) ' find all {..}
Static iPosL& '
Dim iPosR&
If iPosL = 0 Then iPosL = 1
iPosL = InStr(iPosL, Haystack, "{") ' Left
If iPosL = 0 Then Exit Function ' no more
iPosR = InStr(iPosL, Haystack, "}") ' Right
If iPosR = 0 Then MsgBox "No matching }": Stop
zParse = Mid$(Haystack, iPosL + 1, iPosR - iPosL - 1)
iPosL = iPosR
End Function
1) Use the Mid function to drop the first character:
str = "{Computer1"
str = Mid(str,2)
now str = "Computer1"
2) You can use the Split function to separate these out and combine with the Mid function above
str = "{Computer1}{Computer2}"
splt = Split(str,"}")
for a = 0 to Ubound(splt)
result = Mid(splt(a),2)
next a
3) Add a conditional statement to the above loop
str = "{Computer1}{Computer2}"
splt = Split(str,"}")
for a = 0 to Ubound(splt)
if Left(splt(a),1) = "{" then result = Mid(splt(a),2)
next a
Use this loop and send each result to the desired cell (in the for-next loop) and you should be good to go.
First time posting a question, so please correct me if I do anything I'm not supposed to!
I have a macro written on a button press to compare 2 columns on 2 sheets and output either the value from sheet 2 col 1 in sheet 1 col 6 OR output "None" in sheet1 col 6 if there isn't a match.
My code is buggy and takes a long time to run (around 5000 entry's on sheet 1 and 2000 on sheet 2).
My code works partly; it only matches around 2/3rd's of the col 1's on either sheet.
Sub Find_Sup()
Dim count As Integer
Dim loopend As Integer
Dim PartNo1 As String
Dim PartNo2 As String
Dim partRow As String
Dim SupRow As String
Dim supplier As String
Let partRow = 2
Let SupRow = 2
'Find total parts to check
Sheets("Linnworks Supplier Update").Select
Range("A1").End(xlDown).Select
loopend = Selection.row
Application.ScreenUpdating = False
'main loop
For count = 1 To loopend
jump1:
'progress bar
Application.StatusBar = "Progress: " & count & " of " & loopend & ": " & Format(count / loopend, "0%")
Let PartNo2 = Worksheets("Linnworks Supplier Update").Cells(SupRow, 1).Value
Let supplier = Worksheets("Linnworks Supplier Update").Cells(SupRow, 2).Value
If PartNo2 = "" Then
SupRow = 2
Else
jump2:
Let PartNo1 = Worksheets("Linnworks Stock").Cells(partRow, 1).Value
'add part numbers than do match
If PartNo2 = PartNo1 Then
Let Worksheets("Linnworks Stock").Cells(partRow, 5).Value = supplier
Let partRow = partRow + 1
Let count = count + 1
GoTo jump2
Else
Let SupRow = SupRow + 1
GoTo jump1
End If
End If
Next
Application.StatusBar = True
End Sub
I have done some coding in C and C++ and a little VB.NET. Any help streamlining this code or pointing me in the right direction would be very gratefully received!
I realise there are similar questions but all other options I've tried (nested for each loops) don't seem to work correctly.
This is the closest I've managed to get so far.
Many Thanks for reading
try something like this instead and leave feedback so I can edit the answer to match perfectly
Sub Main()
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Set ws1 = Sheets("Linnworks Supplier Update")
Set ws2 = Sheets("Linnworks Stock")
Dim partNo2 As Range
Dim partNo1 As Range
For Each partNo2 In ws1.Range("A1:A" & ws1.Range("A" & Rows.Count).End(xlUp).Row)
For Each partNo1 In ws2.Range("A1:A" & ws2.Range("A" & Rows.Count).End(xlUp).Row)
If StrComp(Trim(partNo2), Trim(partNo1), vbTextCompare) = 0 Then
ws2.Range("E" & partNo1.Row) = partNo2.Offset(0, 1)
ws2.Range("F" & partNo1.Row) = partNo2
End If
Next
Next
'now if no match was found then put NO MATCH in cell
for each partno1 in ws2.Range("E1:F" & ws2.Range("A" & Rows.Count).End(xlUp).Row)
if isempty(partno1) then partno1 = "no match"
next
End Sub