Posts by vcoolio

Sub TestCopy()


Dim ws As Worksheet, sh As Worksheet
Set sh = Sheet1


Application.ScreenUpdating = False


For Each ws In Worksheets
If ws.Name <> "Sheet37" Then
sh.Rows("1:13").Copy ws.[A1]
End If
Next ws


Application.ScreenUpdating = True


End Sub

Option Explicit
Sub Format_Data2()
        Dim i As Long, lr As Long, ar As Variant
        Dim ws As Worksheet: Set ws = Sheet1
       
        lr = ws.Range("A" & Rows.Count).End(xlUp).Row
        ws.Range("E1:E" & lr).AdvancedFilter 2, , ws.[M1], 1  'Unique values moved temporarily to Column M.
        ar = ws.Range("M2", ws.Range("M" & ws.Rows.Count).End(xlUp))
Application.ScreenUpdating = False
          For i = 1 To UBound(ar)
              With ws.Range("E1", ws.Range("E" & ws.Rows.Count).End(xlUp))
                   .AutoFilter 1, ar(i, 1)
                        With .Offset(1)
                        If ar(i, 1) = "abc.com" Then
                                .Offset(, -1).Resize(.Rows.Count - 1) = "fakecompany1"
                                .Offset(, -2).Resize(.Rows.Count - 1) = "fakesegment1"
                        End If
                        If ar(i, 1) = "bcd.com" Then
                                .Offset(, -1).Resize(.Rows.Count - 1) = "fakecompany2"
                                .Offset(, -2).Resize(.Rows.Count - 1) = "fakesegment2"
                        End If
                        If ar(i, 1) = "edc.com" Then
                                .Offset(, -1).Resize(.Rows.Count - 1) = "fakecompany3"
                                .Offset(, -2).Resize(.Rows.Count - 1) = "fakesegment3"
                        End If
                        If ar(i, 1) = "blah.com" Then
                                .Offset(, -1).Resize(.Rows.Count - 1) = "fakecompany2"
                                .Offset(, -2).Resize(.Rows.Count - 1) = "fakesegment2"
                        End If
                        If ar(i, 1) = "bbb.com" Then
                                .Offset(, -1).Resize(.Rows.Count - 1) = "fakecompany3"
                                .Offset(, -2).Resize(.Rows.Count - 1) = "fakesegment3"
                        End If
                        If ar(i, 1) = "aa.com" Then
                                .Offset(, -1).Resize(.Rows.Count - 1) = "fakecompany2"
                                .Offset(, -2).Resize(.Rows.Count - 1) = "fakesegment2"
                        End If
                                .AutoFilter
                        End With
                End With
          Next i
ws.Columns.AutoFit
ws.Columns("M").Clear
Application.ScreenUpdating = True
End Sub

Sub populateBnC()

Dim i As Long
Dim lr As Long: lr = Sheet1.Range("A" & Rows.Count).End(xlUp).Row

Application.ScreenUpdating = False

        For i = 2 To lr
                If Sheet1.Cells(i, 1).Value = "abc.com" Then
                Sheet1.Cells(i, 2).Value = "fakecompany1"
                Sheet1.Cells(i, 3).Value = "fakesegment1"
                Else
                Sheet1.Cells(i, 2).Value = "n/a"
                Sheet1.Cells(i, 3).Value = "n/a"
                End If
        Next i

Application.ScreenUpdating = True

End Sub

Sub Test()


Application.ScreenUpdating = False


With Sheet1.Range("A1", Sheet1.Range("A" & Sheet1.Rows.Count).End(xlUp))
.AutoFilter 1, "abc.com"
.Offset(1, 1).Resize(.Rows.Count - 1) = "Fakecompany1"
.Offset(1, 2).Resize(.Rows.Count - 1) = "Fakesegment1"
.AutoFilter
End With


Application.ScreenUpdating = True


End Sub

Private Sub Worksheet_Change(ByVal Target As Range)


If Intersect(Target, Columns(9)) Is Nothing Then Exit Sub
If Target.Count > 1 Then Exit Sub
If Target.Value = vbNullString Then Exit Sub


Application.ScreenUpdating = False


If Target.Value = "Close" Then
Target.Offset(, 1) = Date
Target.EntireRow.Copy Sheets("Closed Quotes").Range("A" & Rows.Count).End(3)(2)
ElseIf Target.Value = "Open" Then
Target.Offset(, 1) = Date
Range(Cells(Target.Row, "E"), Cells(Target.Row, "J")).Copy Sheets("Open Jobs").Range("C" & Rows.Count).End(3)(2)
End If


Application.ScreenUpdating = True


End Sub

Sub Test()


Application.ScreenUpdating = False


Dim cArr As Variant, pArr As Variant, i As Long
Dim wsD As Worksheet
Dim ws1 As Worksheet
Set ws = Worksheets("Data")
Set wsD = Worksheets(ws.[J1].Value)


nrow = wsD.Cells(Rows.Count, 1).End(xlUp).Row + 1


cArr = Array("B3", "D3", "B5", "D5", "F5")
pArr = Array("A", "B", "C", "D", "E")


For i = LBound(cArr) To UBound(cArr)
ws.Range(cArr(i)).Copy
wsD.Range(pArr(i) & nrow).PasteSpecial xlPasteValues
Next i


Application.CutCopyMode = False
Application.ScreenUpdating = True


End Sub

Option Explicit
Sub Uniques()


Dim c As Range, ar As Variant, var As Variant
Dim Rng As Range: Set Rng = Sheet2.Range("Q2", Sheet2.Range("Q" & Sheet2.Rows.Count).End(xlUp))


With Rng
With CreateObject("Scripting.Dictionary")
For Each c In Rng
var = .Item(c.Value)
Next c
ar = .Keys
End With
End With


Sheet1.Range("A14").Resize(UBound(ar) + 1) = Application.Transpose(ar)


End Sub

Sub Test()


Dim stgF As String, stgP As String
Dim lr As Long, nr As Long, i As Long
Dim wb As Workbook
Dim ws1 As Worksheet: Set ws1 = ThisWorkbook.Worksheets("Sheet1")
Dim ws2 As Worksheet: Set ws2 = ThisWorkbook.Worksheets("Sheet2")
Dim ws3 As Worksheet: Set ws3 = ThisWorkbook.Worksheets("Sheet3")
Dim sh As Worksheet, cAr As Variant, pAr As Variant


stgP = "C:\Users\YOUR FILE PATH HERE"
stgF = Dir(stgP & "\*.xls*")


Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.DisplayAlerts = False


For Each sh In ThisWorkbook.Worksheets
sh.UsedRange.Offset(1).Clear
Next sh


Do While stgF <> vbNullString
Set wb = Workbooks.Open(stgP & "\" & stgF)
cAr = Array(wb.Sheets("Sheet1"), wb.Sheets("Sheet2"), wb.Sheets("Sheet3"))
pAr = Array(ws1, ws2, ws3)


For i = 0 To UBound(cAr)
cAr(i).UsedRange.Offset(1).Copy pAr(i).Range("B" & Rows.Count).End(3)(2)
lr = pAr(i).Cells(Rows.Count, "N").End(xlUp).Row
nr = pAr(i).Cells(Rows.Count, "A").End(xlUp).Row + 1
pAr(i).Range("A" & nr & ":A" & lr) = wb.Name
Next i


wb.Close Save = False
stgF = Dir()
Loop


Application.Calculation = xlCalculationAutomatic
Application.DisplayAlerts = True
Application.ScreenUpdating = True


End Sub

Option Explicit
Sub Test()


Dim sh As Worksheet, wsD As Worksheet, i As Long, nrow As Long
Dim ClArr As Variant, pArr As Variant


Set sh = Sheets("cvent21")
Set wsD = Sheets("2021")


ClArr = Array(4, 21, 22, 23, 3, 24, 14, 19, 9)
pArr = Array("A", "B", "C", "D", "E", "F", "G", "H", "L")
nrow = wsD.Cells(Rows.Count, 1).End(xlUp).Row + 1


Application.ScreenUpdating = False


With sh.[A1].CurrentRegion
.AutoFilter 26, "Y"
With .Offset(1)
For i = LBound(ClArr) To UBound(ClArr)
.Columns(ClArr(i)).Copy wsD.Range(pArr(i) & nrow)
Next i
End With
.AutoFilter
wsD.Columns.AutoFit
End With


Application.ScreenUpdating = True


End Sub

Option Explicit
Sub Test()


Dim sh As Worksheet, wsR As Worksheet, i As Long, nrow As Long
Dim ClArr As Variant, pArr As Variant, Crit1 As String, Crit2 As String


Set sh = Sheets("Data")
Set wsR = Sheets("Report")
wsR.[A3].CurrentRegion.Offset(1).Clear
Crit1 = Sheet1.[B3].Value
Crit2 = Sheet1.[B5].Value
ClArr = Array(1, 2, 3, 4, 5, 8)
pArr = Array("A", "F", "B", "C", "D", "E")
nrow = wsR.Cells(Rows.Count, 1).End(xlUp).Row + 1


Application.ScreenUpdating = False


With sh.[A1].CurrentRegion
.AutoFilter 4, Crit1
.AutoFilter 5, Crit2
With .Offset(1)
For i = LBound(ClArr) To UBound(ClArr)
.Columns(ClArr(i)).Copy wsR.Range(pArr(i) & nrow)
Next i
End With
.AutoFilter
wsR.Columns.AutoFit
End With


Application.ScreenUpdating = True


End Sub