Posts by vcoolio

vcoolio · Nov 8th 2022

Hello Greenestdays,

Automating the autofilter should do the task for you and be much quicker than a looping construct. Hence, try the following:-

Code

Sub Test()

    Dim wsMD As Worksheet, wsMG As Worksheet
    Set wsMD = Sheets("Master Data")
    Set wsMG = Sheets("MG")
    
    Application.ScreenUpdating = False
    
    With wsMD.[A1].CurrentRegion
            .AutoFilter 70, "Y"
            .CurrentRegion.Offset(1).Copy wsMG.Range("A" & Rows.Count).End(3)(2)
            .AutoFilter
    End With
    
    Application.ScreenUpdating = True

End Sub

Display More

I hope that this helps.

Cheerio,

vcoolio.

vcoolio · Jul 18th 2022

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

Cheerio,

vcoolio.

vcoolio · Jul 17th 2022

Hello VA,

I've just realised that in the code above I've mistakenly set the sh variable to Sheet1. It should be 37.

Cheerio,

vcoolio.

vcoolio · Jul 17th 2022

Hello VA,

Are you looking at copy/pasting rows 1-13 from sheet37 (assume this is the sheet code) to all the other sheets starting at A1? If so, try the code amended as follows:-

Code

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

Display More

You'll need to change Sheet37 to the actual name of your source sheet.

I hope that this helps.

Cheerio,

vcoolio.

vcoolio · Feb 7th 2022

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.

vcoolio · Nov 10th 2021

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):-

Code

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

Display More

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

vcoolio · Nov 10th 2021

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.

vcoolio · Nov 9th 2021

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.

vcoolio · Nov 9th 2021

Hello Fullhouse,

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

Code

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

Display More

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:-

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:-

Code

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

Display More

I hope that this helps.

Cheerio,

vcoolio.

vcoolio · Nov 5th 2021

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

Cheerio,

vcoolio.

vcoolio · Nov 5th 2021

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.

vcoolio · Nov 5th 2021

Hello Alexiz,

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

Code

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

Display More

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

vcoolio · Nov 5th 2021

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.

vcoolio · Nov 5th 2021

Hello Intranet,

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

Code

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

Display More

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

vcoolio · Oct 3rd 2021

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.

vcoolio · Oct 3rd 2021

Hello JH,

Another option:-

Code

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

Display More

I hope that this helps.

Cheerio,

vcoolio.

vcoolio · Sep 24th 2021

Hello Funfex,

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

Code

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

Display More

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

I hope that this helps.

Cheerio,

vcoolio.

vcoolio · Sep 3rd 2021

Hello JLW-E,

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

Cheerio,

vcoolio.

vcoolio · Sep 3rd 2021

Hello JLW-E,

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

Code

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

Display More

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.

vcoolio · Aug 28th 2021

Hello MAID1812,

Here's another VBA option:-

Code

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

Display More

I hope that this helps.

Cheerio,

vcoolio.

Posts by vcoolio

Copy partial row based on cell value in to sheets

VBA Macro to Insert Rows into All Visible Sheets

VBA Macro to Insert Rows into All Visible Sheets

VBA Macro to Insert Rows into All Visible Sheets

How to Relocate a row of cells automatically based on the value in the cell

return value to multiple columns based on specific text from a specific column

return value to multiple columns based on specific text from a specific column

return value to multiple columns based on specific text from a specific column

return value to multiple columns based on specific text from a specific column

Move certain data from one column to another sheet based on selection in drop down selection

Save data in the respective worksheet with variable using macro

Move certain data from one column to another sheet based on selection in drop down selection

Move certain data from one column to another sheet based on selection in drop down selection

Save data in the respective worksheet with variable using macro

Use VBA to Copy & Paste Unique Value from One Worksheet to Another (Paste as Values)

Use VBA to Copy & Paste Unique Value from One Worksheet to Another (Paste as Values)

Help with Macro to Merge Multiple files with Multiple Tabs

Append new data rows (selected columns only) from one worksheet to another

Append new data rows (selected columns only) from one worksheet to another

Autofilter and Copy Selected Columns to a new Sheet (in a different order)