Another option:
Sub CopySheet()
Application.ScreenUpdating = False
Sheets("Spare").Copy after:=Sheets(Sheets.Count)
ActiveSheet.Name = Sheets("Setup").Range("A1")
Application.ScreenUpdating = False
End Sub
Another option:
Sub CopySheet()
Application.ScreenUpdating = False
Sheets("Spare").Copy after:=Sheets(Sheets.Count)
ActiveSheet.Name = Sheets("Setup").Range("A1")
Application.ScreenUpdating = False
End Sub
Try this macro:
Sub CompareData()
Application.ScreenUpdating = False
Dim v As Variant, r As Long, c As Long, dic As Object
v = Range("A2", Range("A" & Rows.Count).End(xlUp)).Resize(, 4).Value
Set dic = CreateObject("Scripting.Dictionary")
For r = LBound(v) To UBound(v)
For c = LBound(v, 2) To UBound(v, 2)
If Not dic.exists(v(r, c)) Then
dic.Add v(r, c), Nothing
End If
Next c
Range("F" & r + 1) = Join(dic.keys, "+")
dic.RemoveAll
Next r
Application.ScreenUpdating = True
End Sub
Display More
Try:
Sub Title()
Dim srcWS As Worksheet, desWS As Worksheet
Set srcWS = Workbooks("Filename.xlsm").Worksheets("Sheet1")
Set desWS = Workbooks("Filename2.xlsm").Worksheets("Sheet2")
With desWS
srcWS.Range("A1:D20").Copy
.Cells(.Rows.Count, "A").End(xlUp).Offset (1), PasteSpecial, xlPasteValues
.Cells(.Rows.Count, "A").End(xlUp).Offset (1), PasteSpecial, xlPasteFormats
End With
Application.CutCopyMode = False
End Sub
Display More
You currently have a userform that can be used to do the search. You also have the "SearchBox" sheet that seems to be the same as the userform. Do you want to use the "SearchBox" sheet or the userform to do the search? Please clarify in detail.
Place this macro in the code module for ThisWorkbook. Do the following: Hold down the ALT key and press the F11 key. This will open the Visual Basic Editor. In the left hand pane, double click on "ThisWorkbook". Copy/paste the macro into the empty window that opens up. Close the window to return to your sheet. Save the file.
You have some data starting in row 1255. Before trying the macro below, delete all that data.
Sub TransposeData()
Application.ScreenUpdating = False
Dim lRow As Long, x As Long, v As Variant, arr() As Variant
lRow = Range("BP" & Rows.Count).End(xlUp).Row
Range("BP:BP").Resize(, lRow + 1).Insert Shift:=xlToRight
With Range("BP1:BQ1")
.Value = Array("Month", "Value")
.Interior.ColorIndex = 3
End With
Range("BP2").Resize(12).Value = Application.Transpose(Cells(1, 67 + lRow + 2).Resize(, 12).Value)
For x = 78 To 90
Cells(Rows.Count, "BQ").End(xlUp).Offset(1).Resize(, lRow - 1).Value = Application.Transpose(Cells(2, x).Resize(lRow - 1))
Next x
Cells(1, 67 + lRow + 1).Resize(, 13).EntireColumn.Delete
Application.ScreenUpdating = True
End Sub
Display More
It is hard to work with a picture. Attach a copy of your file and include a manually created sheet showing what you want your end result to look like.
Try:
Sub MoveDataUp()
Application.ScreenUpdating = False
Dim i As Long, lRow As Long, fRow As Long
lRow = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
With Range("A2:A" & lRow).SpecialCells(xlCellTypeConstants)
For i = 1 To .Areas.Count
fRow = .Areas(i).Cells(1).Row
lRow = .Areas(i).Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
If fRow = lRow Then
Range("A" & fRow).Cut Range("A" & fRow - 1)
End If
Next i
End With
Application.ScreenUpdating = True
End Sub
Display More
Try:
Sub DeleteEmptyRowsColumns()
Application.ScreenUpdating = False
Dim x As Long
With ActiveSheet
For x = .UsedRange.Rows.Count To 1 Step -1
If WorksheetFunction.CountA(.Rows(x)) = 0 Then .Rows(x).EntireRow.Delete
Next
For x = .UsedRange.Columns.Count To 1 Step -1
If WorksheetFunction.CountA(.Columns(x)) = 0 Then .Columns(x).EntireColumn.Delete
Next
.UsedRange.SpecialCells(xlBlanks) = 0
End With
Application.ScreenUpdating = True
End Sub
Display More
Try:
Sub ConcatValues()
Application.ScreenUpdating = False
Dim srcRng As Range, i As Long, v As Variant, lRow As Long, c As Range, txt As String
lRow = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
v = Range("B2:B" & lRow).Value
For i = LBound(v) To UBound(v)
Range("A1").AutoFilter 2, v(i, 1)
Set srcRng = Range("A2:A" & lRow).SpecialCells(xlVisible)
For Each c In srcRng
txt = txt & c.Value & ", "
Next c
txt = Left(txt, Len(txt) - 2)
Range("C" & i + 1).Value = txt
txt = ""
Next i
Range("A1").AutoFilter
Application.ScreenUpdating = True
End Sub
Display More
Try:
Sub CopyColoredCells()
Application.ScreenUpdating = False
Dim rng As Range, fnd1 As Range, fnd2 As Range, srcWS As Worksheet, desWS As Worksheet
Set srcWS = Sheets("DATA")
Set desWS = Sheets("TEMPLATE")
With srcWS
For Each rng In .Range("C1", .Range("E" & .Rows.Count).End(xlUp))
If rng.Interior.ColorIndex <> xlNone Then
Set fnd1 = desWS.Range("A:A").Find(.Range("A" & rng.Row), LookIn:=xlValues, lookat:=xlWhole)
If Not fnd1 Is Nothing Then
Set fnd2 = desWS.Rows(1).Find(.Cells(1, rng.Column), LookIn:=xlValues, lookat:=xlWhole)
If Not fnd2 Is Nothing Then
desWS.Cells(fnd1.Row, fnd2.Column) = rng
End If
End If
End If
Next rng
End With
Application.ScreenUpdating = True
End Sub
Display More
Try:
Sub TransposeData()
Application.ScreenUpdating = False
Dim v As Variant, i As Long, lRow As Long, fVisRow As Long, lVisRow As Long, srcRng As Range, rng As Range
lRow = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
v = Range("A2:A" & lRow)
For i = LBound(v) To UBound(v)
Range("A1").CurrentRegion.AutoFilter 1, v(i, 1)
fVisRow = Rows("2:" & lRow).SpecialCells(xlCellTypeVisible).Row
lVisRow = Cells(Rows.Count, "A").End(xlUp).Row
If [subtotal(103,A:A)] - 1 > 1 Then
Set srcRng = Range("C" & fVisRow + 1 & ":C" & lVisRow)
Cells(fVisRow, Cells(fVisRow, Columns.Count).End(xlToLeft).Column + 1).Resize(, [subtotal(103,A:A)] - 2) = WorksheetFunction.Transpose(srcRng)
srcRng.EntireRow.Delete
End If
Next i
Range("A1").AutoFilter
Application.ScreenUpdating = False
End Sub
Display More
Could you attach a copy of your file? It would be easier to see how your data is organized and to test possible solutions. Include a detailed explanation
of what you want to do using a few examples from your data and referring to specific cells, rows, columns and sheets. De-sensitize the data if necessary.
Could you attach a copy of your file? It would be easier to see how your data is organized and to test possible solutions. Include a detailed explanation
of what you want to do using a few examples from your data and referring to specific cells, rows, columns and sheets. De-sensitize the data if necessary. Also include an explanation of how you want to name each PDF file and where you want to save it.
Try:
Try:
Sub OrdersEmailing2Customers()
Application.ScreenUpdating = False
Dim v As Variant, i As Long, OutApp As Object, OutMail As Object, rng As Range, lRow As Long
Dim srcWS As Worksheet, recipient As Range
Set srcWS = Sheets("Orders")
With srcWS
lRow = .Range("D" & Rows.Count).End(xlUp).Row
v = .Range("B2:B" & lRow).Value
End With
Set OutApp = CreateObject("Outlook.Application")
With CreateObject("scripting.dictionary")
For i = LBound(v) To UBound(v)
Set recipient = Sheets("MailAddresses").Range("A:A").Find(v(i, 1), LookIn:=xlValues, lookat:=xlWhole)
If Not recipient Is Nothing Then
If Not .exists(v(i, 1)) Then
.Add v(i, 1), Nothing
srcWS.Range("A1").AutoFilter 2, v(i, 1)
Set rng = Intersect(srcWS.Rows("1:" & lRow), srcWS.Range("C:D,F:H").SpecialCells(xlCellTypeVisible))
Set OutMail = OutApp.CreateItem(0)
With OutMail
.To = recipient.Offset(, 1)
.Subject = "SHIPPING NOTIFICATION"
.HTMLBody = "Dear Valued Abbott Customer," & "<br><br>" _
& "Please see below list of items that are planned for shipping." & "<br>" _
& "Please expect delivery to occur within the next 5 business days." & "<br><br>" _
& RangetoHTML(rng) & "<br><br>" _
& "Should your delivery not occur during this period, please enquire with [email protected]." & "<br><br>" _
& "Kind Regards," & "<br><br>" _
& "Customer Service & Logistics" & "<br>" _
& "Core Diagnostics South Africa" & "<br>" _
& "Email: [email protected]"
'.send
.display
End With
End If
Else
MsgBox ("Customer " & v(i, 1) & " not found.")
End If
Next i
End With
srcWS.Range("A1").AutoFilter
Application.ScreenUpdating = True
End Sub
Function RangetoHTML(rng As Range)
Dim fso As Object
Dim ts As Object
Dim TempFile As String
Dim TempWB As Workbook
TempFile = Environ$("temp") & "\" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
rng.Copy
Set TempWB = Workbooks.Add(1)
With TempWB.Sheets(1)
.Cells(1).PasteSpecial Paste:=8
.Cells(1).PasteSpecial xlPasteValues, , False, False
.Cells(1).PasteSpecial xlPasteFormats, , False, False
.Cells(1).Select
Application.CutCopyMode = False
On Error Resume Next
.DrawingObjects.Visible = True
.DrawingObjects.Delete
On Error GoTo 0
End With
With TempWB.PublishObjects.Add( _
SourceType:=xlSourceRange, _
Filename:=TempFile, _
Sheet:=TempWB.Sheets(1).Name, _
Source:=TempWB.Sheets(1).UsedRange.Address, _
HtmlType:=xlHtmlStatic)
.Publish (True)
End With
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
RangetoHTML = ts.readall
ts.Close
RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", "align=left x:publishsource=")
TempWB.Close savechanges:=False
Kill TempFile
Set ts = Nothing
Set fso = Nothing
Set TempWB = Nothing
End Function
Display More
Please note that I have set the macro to display rather than send the emails. Change the code to suit your needs.
Don't unmerge the cells and try this version of the macro. I have removed the autofit line of code. To test the macro, I created up to 12 new workbooks and it worked properly.
Sub Generate()
Application.ScreenUpdating = False
Dim LastRow As Long, ID As Range, srcWB As Workbook, srcWS As Worksheet
Set srcWB = ThisWorkbook
Set srcWS = srcWB.Sheets("ID")
LastRow = srcWS.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
For Each ID In srcWS.Range("B3:B" & LastRow)
Sheets("Template").Copy
With ActiveWorkbook
With .ActiveSheet
.Range("Q2") = ID
.UsedRange.Cells.Copy
.Range("B1").PasteSpecial xlPasteValues
End With
.SaveAs srcWB.Path & Application.PathSeparator & Range("Q2") & ".xlsx", FileFormat:=51
.Close False
End With
Next ID
Application.ScreenUpdating = True
End Sub
Display More