Posts by vcoolio

Hello Mo,

You had best upload a sample of your workbook and also give us a precise description of what you intend to do.

Cheerio,

vcoolio.

Hello Fullhouse,

You're welcome and I'm glad to have been able to assist.

I'm really happy that you spent the time foraging through information and working this out basically on your own. I laud you for that.

If you're interested, below is a condensed version of your code (but excluding the date part that you added in):-

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

If you're willing to do a bit more research, what I've done in the above code is extract all the unique values in Column E using the AdvancedFilter and temporarily placing them in Column M. These unique values are then placed into an array(ar) which is then looped through and filtered for each unique value. This prevents many, many iterations which in turn speeds up the code and, as you stated earlier, you have around 100K rows of data so the saved iterations would be in the thousands. I tested this code on 150K rows and it took about three seconds to execute on my machine.

Column M is cleared at the end of code execution.

As you can see in the code, I've used 'IF' statements to identify the unique values for processing once filtered. You may want to research 'case statements in VBA' if you have the time. 'Case statements' can be used in place of 'IF' statements and may actually work more quickly.

Anyway, once again "well done" and good luck with your project.

I've attached your sample workbook with the above code implemented just so you can see how it works. There are about 230 rows of data in the sample.

Cheerio,

vcoolio.

Fullhouse.xlsm

Hello Fullhouse,

Quote

My understanding is that if abc.com is in the column E and i want fake company in the column D, then the column offset is -1, but I am not sure what do i put on for row?

For each instance of abc.com, the offset for the same row but the previous column(D) is written as:

.Offset(, -1)

However, based on your last post, it appears that the sample you supplied is not exactly what you are working with so the best option is for you to upload a sample of your workbook which is an exact replica of your actual working workbook. If your data is sensitive then please use dummy data. We'll only need a dozen or so rows of data to test with. Please also include the code that you are presently working with. This will make it much easier for us to resolve this for you and will spare us guessing at what is supposed to actually be happening.

Cheerio,

vcoolio.

Hello Fullhouse,

You're welcome. I'm glad to have been able to assist.

Smart choice going with the Autofilter.

Does the Autofilter code in my first post do the task for you?

Cheerio,

vcoolio.

Hello Fullhouse,

You don't need the "AND" operator, so modifying your loop type code as follows may help:-

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

You'll note that the last row has been defined so the code will loop each cell in Column A to the last row (the rows are defined by the variable 'i'), find the value 'abc.com' and add the text to Columns B and C. Based on the sample that you have supplied, Sheets("Sheet2") has the sheet code 'Sheet1' which I have used above.

In this line of your code:-

If Worksheets("Sheet1").Cells(2, 1).Value = "abc.com" Then

I'm not sure if Worksheets("Sheet1") is a typo on your part.

A loop type code will work fairly quickly on a relatively small data set but if your data set is large, or could grow to be very large, using the AutoFilter will be a far better option. For example:-

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

I hope that this helps.

Cheerio,

vcoolio.

You're welcome Alexi. I'm glad to have been able to assist.

Cheerio,

vcoolio.

You're welcome Intranet. I'm glad to have been able to assist and thanks for the feed back.

BTW, I just noticed a little typo in the code and I'm surprised that you didn't receive and error message.

This line:-

Dim ws1 As Worksheet

should be

Dim ws As Worksheet

Cheerio,

vcoolio.

Hello Alexiz,

Should you want to stay with your current method, a worksheet_change event code should do the task for you:-

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

With this code, each time you make an "Open" or "Close" selection from the drop downs, the data will be immediately transferred to its relevant sheet.

To implement this code:-

- Right click on the "Quotes" sheet tab.

- Select "View Code" from the menu that appears.

- In the big white code field that then appears, paste the above code.

You'll need to first delete all existing codes that you have.

I've attached your sample with the code implemented and all other codes removed. Test it to see if it's what you were hoping to achieve.

I hope that this helps.

Cheerio,

vcoolio.

Alexiz.xlsm

Hello Alexiz,

Could you please upload a sample of your file as images are not much help to anyone who may offer you assistance. We can easily test procedures with an actual file. Ensure that you use dummy data in your sample just as your images appear to have.

Cheerio,

vcoolio.

Hello Intranet,

Based on the information that you have supplied, the following VBA code may help:-

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

Place the code into a standard module and assign it to a button.

I've attached your sample workbook with the code implemented. Just click on the "TEST ME" button to see how it works. Play with the data to see how it is transferred to the relevant 'name' sheet.

I hope that this helps.

Cheerio,

vcoolio.

Intranet.xlsm

You're welcome JH. I'm glad to have been able to assist.

I gather that you worked out how to change the destination target from A14 to A6 (opening post/post #5).

Good luck with your project.

Cheerio,

vcoolio.

Hello JH,

Another option:-

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

I hope that this helps.

Cheerio,

vcoolio.

Hello Funfex,

See if this at least heads you in the right direction:-

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

You'll need to place your file path in the variable stgP.

I hope that this helps.

Cheerio,

vcoolio.

Hello JLW-E,

You're welcome. I'm glad to have been able to assist.

Cheerio,

vcoolio.

Hello JLW-E,

See if the following code does the trick for you (untested):-

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

I've added a simple criteria column(Z) to determine if an entry is a new registrant. Place a "Y" in a cell and the code will do the rest.

I hope that this helps.

Cheerio,

vcoolio.

Hello MAID1812,

Here's another VBA option:-

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

I hope that this helps.

Cheerio,

vcoolio.

Hello DezB,

I'm assuming that you have been using Gijsmo's code as the code I supplied doesn't include a message box.

So I'll hand you back to Gijsmo.

Cheerio,

vcoolio.

Hello Anna,

Column 9 is not included because, in your sample output, you have not included it (Coco).

If you need it to be included, add 9 after the 8 in the array and change the resize value to 12.

The array appears random but is in fact quite precise. You have asked that columns K, L and M (10, 11 &12 based on your data setout) in the Input sheet be placed in columns E, F and G in the Output sheet starting at B4. The positions of the columns in the array determines the positions in the Output sheet.

I don't quite follow your last request so, seeing that your supplied sample is not truly indicative of your actual workbook and its data, please supply a new sample set out exactly the same as your actual workbook including the data within the columns (ensure that it is still dummy data).

Cheerio,

vcoolio.

Hello Anna,

See if this heads you in the right direction:-

Option Explicit


Sub Test()


Dim ar As Variant


Sheet1.UsedRange.ClearContents


With Sheet2.[B3].CurrentRegion
ar = Application.Index(.Value, Evaluate("Row(1:" & .Rows.Count & ")"), Array(1, 2, 3, 10, 11, 12, 4, 5, 6, 7, 8))
End With


Sheet1.[B4].Resize(UBound(ar), 11) = ar
Sheet1.Columns.AutoFit


End Sub

I've attached your sample workbook with the code implemented. The "Output" sheet is empty. Click on the "TEST ME" button to see how it works.

I hope that this helps.

Cheerio,

vcoolio.

Anna.xlsm

Hello DezB,

In reply to your questions:-

.Offset(1, -15).Resize(, 16).Copy ws2.Range("A" & Rows.Count).End(3)(2)

With the code in post #5, Column P(16) is the criteria column on which the filter is applied. Once applied, the filtered data to be copy/pasted starts on the next row down from the headings row, hence: .Offset(1). However, since the criteria is in Column P and Columns A:P are the required columns to be copy/pasted, we need to resize from Column A (otherwise .Offset(1) will only copy/paste the "Yes" criteria). Hence .Offset(1,-15).Resize(,16). The -15 takes us back to Column A and the resize property (,16 columns) does the rest.

.End(3) (2) is simply the enumeration for .End(xlUp).Offset(1). They are exactly the same thing, just less typing!

If row2 in your data set is completely empty, then the code could be written as follows:-

Option Explicit
Sub DezB()


Dim ws1 As Worksheet: Set ws1 = Sheets("Active_Cases")
Dim ws2 As Worksheet: Set ws2 = Sheets("Archived_Cases")


Application.ScreenUpdating = False


With ws1.[A3].CurrentRegion
.AutoFilter 16, "Yes"
.Offset(1).Copy ws2.Range("A" & Rows.Count).End(3)(2)
.Offset(1).EntireRow.Delete
.AutoFilter
End With


Application.ScreenUpdating = True


End Sub

You'll note the Autofilter is now set to: .AutoFilter 16 (to identify Column P within the CurrentRegion).

The copy line of code is simply

.Offset(1).Copy ws2.Range("A" & Rows.Count).End(3)(2)

which takes the entire (entire rows) filtered data set and copy/pastes it. If you're only interested in Columns A:P and nothing beyond, then you could use this:-

.Offset(1).Resize(, 16).Copy ws2.Range("A" & Rows.Count).End(3)(2)

With more columns, just change the resize value. If the precise amount of columns to be copy/pasted isn't an issue then just change

.Resize(, 16) to .EntireRow

All in all, the CurrentRegion method is a very versatile way of doing tasks like yours so, if you add more columns, they will be instantly added to the whole procedure. You'll only need to change the reference to the criteria column.

Take note though, when using the CurrentRegion method, if your data doesn't start in row1 with headings, then the data needs to be bounded by at least one empty row and one empty column.

Another method is to define the range to be filtered:-

Option Explicit
Sub DezB()


Dim ws1 As Worksheet: Set ws1 = Sheets("Active_Cases")
Dim ws2 As Worksheet: Set ws2 = Sheets("Archived_Cases")


Application.ScreenUpdating = False


With ws1.Range("A3", ws1.Range("P" & ws1.Rows.Count).End(xlUp))
.AutoFilter 16, "Yes"
.Offset(1).Resize(, 16).Copy ws2.Range("A" & Rows.Count).End(3)(2)
.Offset(1).EntireRow.Delete
.AutoFilter
End With


Application.ScreenUpdating = True


End Sub

This is the range you're interested in (it's also fully qualified with the worksheet variable (ws1):

With ws1.Range("A3", ws1.Range("P" & ws1.Rows.Count).End(xlUp))

and you'll note that the filter is still set on Column P(16).

There are more options which can be used to do the same task but between this post and Gijsmo's post #14, your head is probably spinning a little.

The method used is basically a Coder's preference.

I hope you've been enlightened somewhat.

Cheerio,

vcoolio.