Choose the starting cell of a do-loop - excel

I want to start a loop mid column (Row 15 let's say).
Current code (part of a much larger script)
Range("C2").FormulaR1C1 = "=[OrderForm.xlsx]Order!R15C3"
Dim BlankFound As Boolean
Dim x As Long
'Loop until a blank cell is found in Column C
Do While BlankFound = False
x = x + 1
If Cells(x, "C").Value = "" Then
BlankFound = True
End If
Loop
I tried changing the column ref (C) to a cell (C15). I tried to specify the start and end point (C15:C).
We have a client order form that when they click a button converts to another format ready to be uploaded. The client will fill out various fields that populate rows 1 and 2 (name, address, etc.), then from row three it is the number of orders, i.e.
row
3 part number quantity availability
4 part number quantity availability
I want it to look at the original form and only populate down if it finds a value in the original form's cell.
Then at the end I have another row to add, so I need to be able to say when this loop finishes, add these values (these are just an extra row of totals and some formatting).
The full code-
Sub ButtonMacroLatest()
'Hide alerts
Application.DisplayAlerts = False
'
' Macro8 Macro
'
'Save to users device
ChDir "U:\WINDOWS"
ActiveWorkbook.SaveAs Filename:="U:\WINDOWS\OrderForm.xlsx", FileFormat:= _
xlOpenXMLWorkbook, CreateBackup:=False
'Create new workbook and populate
Workbooks.Add
ActiveCell.FormulaR1C1 = "MSG"
Range("B1").FormulaR1C1 = "=[OrderForm.xlsx]Order!R[1]C"
Range("C1").FormulaR1C1 = "=[OrderForm.xlsx]Order!R[1]C[3]"
Range("D1").FormulaR1C1 = "1400008000"
Range("E1").FormulaR1C1 = "501346009175"
Range("F1").FormulaR1C1 = "=TODAY()"
Range("G1").FormulaR1C1 = "=Now()"
Selection.NumberFormat = "[$-x-systime]h:mm:ss AM/PM"
Range("A2").FormulaR1C1 = "HDR"
Range("B2").FormulaR1C1 = "C"
Range("C2").FormulaR1C1 = "=[OrderForm.xlsx]Order!R4C2"
Range("G2").FormulaR1C1 = "=[OrderForm.xlsx]Order!R[1]C[3]"
Range("H2").FormulaR1C1 = "=[OrderForm.xlsx]Order!R2C4"
Range("K2").FormulaR1C1 = "STD"
Range("L2").FormulaR1C1 = "=[OrderForm.xlsx]Order!R5C2"
Range("N2").FormulaR1C1 = "=[OrderForm.xlsx]Order!R7C2"
Range("O2").FormulaR1C1 = "=[OrderForm.xlsx]Order!R8C2"
Range("Q2").FormulaR1C1 = "=[OrderForm.xlsx]Order!R9C2"
Range("R2").FormulaR1C1 = "=[OrderForm.xlsx]Order!R12C2"
Range("A3").FormulaR1C1 = "POS"
Range("B3").FormulaR1C1 = "=Row()*10-20"
Range("C3").FormulaR1C1 = "=[OrderForm.xlsx]Order!R15C3"
Dim BlankFound As Boolean
Dim x As Long
'Loop until a blank cell is found in Column C
Do While BlankFound = False
x = 14
x = x + 1
If Cells(x, "C").Value = "" Then
BlankFound = True
End If
Loop
Range("D3").FormulaR1C1 = "=[OrderForm.xlsx]Order!R15C1"
Range("E3").FormulaR1C1 = "=[OrderForm.xlsx]Order!R15C2"
Range("F3").FormulaR1C1 = "=[OrderForm.xlsx]Order!R15C5"
Range("G3").FormulaR1C1 = "=[OrderForm.xlsx]Order!R15C7"
'Preformat cells to remove 0 value
Range("A1:AP1000").Select
Range("AP1000").Activate
Selection.NumberFormat = "#;#;"
Range("H3").FormulaR1C1 = "GBP"
Range("L3").FormulaR1C1 = "TRA"
Range("M3").FormulaR1C1 = "=COUNTIF(C[-3], ""POS"")+COUNTIF(C[-3], ""HDR"")"
'Reinstate alerts
Application.DisplayAlerts = True
End Sub
In the client facing form A15:C15 are material/part numbers. If populated those rows should fill down in the new form until there is no entry in the original form.
Customer form

I haven't been able to figure out exactly where you're grabbing values from and where you're putting them, but hopefully this bit of code will give you enough ideas to get yours sorted.
Public Sub ButtomMacroLatest()
Dim wrkBk As Workbook
Dim wbOF As Workbook
Dim shtCSV As Worksheet
Dim shtOF As Worksheet
Dim lLastRow As Long
Dim x As Long, y As Long
'OrderForm is closed so needs opening:
'Set wbOF = Workbooks.Open("U:\.......\OrderForm.xlsx")
'OrderForm is the workbook containing this code:
Set wbOF = ThisWorkbook
'Set a reference to the "Order" sheet and
'find the last row - based on column A being populated.
Set shtOF = wbOF.Worksheets("Order")
lLastRow = shtOF.Cells(Rows.Count, 1).End(xlUp).Row
'Create workbook with 1 sheet and set reference to that sheet.
Set wrkBk = Workbooks.Add(xlWBATWorksheet)
Set shtCSV = wrkBk.Worksheets(1)
'Add headings to the sheet.
shtCSV.Range("A1:G1") = Array("MSG", "SomeHeading", "SomeOtherHeading", "1400008000", _
"501346009175", Date, Now)
'Copy values in cell "A15:J<LastRow>" to "A2" on the new sheet.
With shtOF
'Straight copy
'.Range(.Cells(15, 1), .Cells(lLastRow, 10)).Copy _
Destination:=shtCSV.Range("A2")
'Paste Special
.Range(.Cells(15, 1), .Cells(lLastRow, 10)).Copy
With shtCSV.Range("A2")
.PasteSpecial xlPasteValuesAndNumberFormats
.PasteSpecial xlPasteFormats
End With
'Make the value of one cell equal the value of another cell
'in a loop from row 15 to LastRow and column 1 to 10.
'For x = 15 To lLastRow
' For y = 1 To 10
' shtCSV.Cells(x - 13, y) = .Cells(x, y)
' Next y
'Next x
End With
wrkBk.SaveAs Environ("temp") & "/CSV File.csv", FileFormat:=xlCSV, CreateBackup:=False
End Sub

This took something a lot simpler, it works a treat for what I need. Code:
'Fills column to last row of data from Cell C15
Dim LastRow As Long
LastRow = Cells.Find(What:="*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
Range("C15:C" & LastRow).FillDown
Range("D15:D" & LastRow).FillDown
Range("E15:E" & LastRow).FillDown
Thanks for all of the responses.

Related

VBA to copy specific cells from one worksheet to another upon meeting a criteria

My VBA knowledge is very limited, so looking for some help here. Tried some Googling and putting together a code but hasn't met the goal. Appreciate the help here!
I have 2 worksheets:
Data - source worksheet with the data to be copied
Dashboard - Target sheet for pasting
Data sheet - It has multiple columns, the ones I have named are the ones I need to be copied except the column named "Sold?" which is for criteria. The other columns with no names in the image actually have data, to avoid confusion I have removed them here.
This sheet grows and I will add a new row of data when needed.
Dashboard Sheet - When I click "Refresh" button, I want the code to check the "Data" sheet and if a row meets of criteria of Sold? = "N", then only data from column C,G,J,M should be copied and pasted into columns B,C,D,E of "Dashboard" sheet. Additional criteria: if an investment name repeats, the details need to be summed up and shown in Dashboard sheet. I have provided my expected output in the image. (ABC & TY summed up)
I have tried a bit but unable to incorporate all the criteria and this code when run doesn't throw an error but does nothing, no output.
Private Sub Refresh_Click()
Worksheets("Dashboard").Activate
Application.ScreenUpdating = True
a = Worksheets("Data").Cells(Rows.Count, "A").End(xlUp).Row
For i = 12 To a
If Worksheets("Data").Cells(i, 15).Value = "N" Then
Worksheets("Data").Cells(i, 3).Copy
Worksheets("Data").Cells(i, 7).Copy
Worksheets("Data").Cells(i, 13).Copy
Worksheets("Data").Cells(i, 14).Copy
Worksheets("Dashboard").Activate
Worksheets("Dashboard").Range("B6:G25").Select
ActiveSheet.Paste
End If
Next
Application.CutCopyMode = False
End Sub
I strongly suggest a pivot table. Still if you want VBA based solution, you might try this code:
Option Explicit
Private Sub Refresh_Click()
'Declarations.
Dim BlnHiddenColumns() As Boolean
Dim DblFirstRow As Double
Dim DblLastRow As Double
Dim DblCounter01 As Double
Dim DblCounterLimit01 As Double
Dim DblInvestmentNameColumn As Double
Dim DblQuantityColumn As Double
Dim DblAfterChargeColumn As Double
Dim DblCurrentPLColumn As Double
Dim DblSoldColumn As Double
Dim RngData As Range
Dim RngResult As Range
Dim StrAutofilterAddress As String
Dim StrMarker As String
Dim StrInvestmentNameHeader As String
Dim StrQuantityHeader As String
Dim StrAfterChargeHeader As String
Dim StrCurrentPLHeader As String
Dim WksData As Worksheet
Dim WksDashboard As Worksheet
Dim WksPivotTable As Worksheet
Dim PvtPivotTable01 As PivotTable
'Settings.
DblInvestmentNameColumn = 3
DblQuantityColumn = 7
DblAfterChargeColumn = 10
DblCurrentPLColumn = 13
DblSoldColumn = 15
DblFirstRow = 12
DblCounterLimit01 = 1000
StrMarker = "N"
Set WksData = Worksheets("Data")
DblLastRow = WksData.Cells(Rows.Count, "B").End(xlUp).Row
Set RngData = WksData.Range(WksData.Cells(DblFirstRow - 1, Excel.WorksheetFunction.Min(DblInvestmentNameColumn, DblQuantityColumn, DblAfterChargeColumn, DblCurrentPLColumn, DblSoldColumn)), WksData.Cells(DblLastRow, Excel.WorksheetFunction.Max(DblInvestmentNameColumn, DblQuantityColumn, DblAfterChargeColumn, DblCurrentPLColumn, DblSoldColumn)))
ReDim BlnHiddenColumns(1 To RngData.Columns.Count)
Set WksDashboard = Worksheets("Dashboard")
Set RngResult = WksDashboard.Range("B6")
StrInvestmentNameHeader = WksDashboard.Range("B5").Value
StrQuantityHeader = WksDashboard.Range("C5").Value
StrAfterChargeHeader = WksDashboard.Range("D5").Value
StrCurrentPLHeader = WksDashboard.Range("E5").Value
'Turning off screen updating.
Application.ScreenUpdating = False
'Checking for any previous results list.
If Excel.WorksheetFunction.CountBlank(RngResult) <> RngResult.Cells.Count Then
DblCounter01 = 0
'Checking each row of the result list until an entirely blank row is found.
Do Until Excel.WorksheetFunction.CountBlank(RngResult.Offset(DblCounter01, 0)) = RngResult.Cells.Count
DblCounter01 = DblCounter01 + 1
'If the number of rows checked is equal or superior to DblCounterLimit01 the macro is terminated.
If DblCounter01 >= DblCounterLimit01 Then
MsgBox "Please clear the current holdings list manually", vbCritical + vbOKOnly, "Unable to clear the current list"
Exit Sub
End If
Loop
'Clearing the list.
RngResult.Parent.Range(RngResult, RngResult.Offset(DblCounter01 - 1)).ClearContents
End If
'Checking for existing autofilter in WksData.
If WksData.AutoFilterMode = True Then
'Coping the address of the autofilter in WksData.
StrAutofilterAddress = WksData.AutoFilter.Range.Address
End If
'Removing any autofilter in WksData.
WksData.AutoFilterMode = False
'Covering each column of RngData.
For DblCounter01 = 1 To RngData.Columns.Count
'Setting BlnHiddenColumns accordingly to the RngData columns' status (hidden/not hidden).
BlnHiddenColumns(DblCounter01) = RngData.Columns(DblCounter01).Hidden
'Hiding the columns of RngData we won't copy.
Select Case DblCounter01 + RngData.Column - 1
Case Is = DblInvestmentNameColumn, DblQuantityColumn, DblAfterChargeColumn, DblCurrentPLColumn
RngData.Columns(DblCounter01).Hidden = False
Case Else
RngData.Columns(DblCounter01).Hidden = True
End Select
Next
'Filtering RngData.
RngData.AutoFilter Field:=DblSoldColumn - RngData.Column + 1, Criteria1:=StrMarker
'Copying the filtered RngData into RngResult.
RngData.Resize(RngData.Rows.Count - 1, RngData.Columns.Count).Offset(1, 0).SpecialCells(xlCellTypeVisible).Copy RngResult
'Restoring the RngData columns to their previous status (hidden/not hidden).
For DblCounter01 = 1 To RngData.Columns.Count
If BlnHiddenColumns(DblCounter01) Then
RngData.Columns(DblCounter01).Hidden = True
Else
RngData.Columns(DblCounter01).Hidden = False
End If
Next
'Removing any autofilter in WksData.
WksData.AutoFilterMode = False
'Restoring any pre-existing autofilter in WksData.
If StrAutofilterAddress <> "" Then
WksData.Range(StrAutofilterAddress).AutoFilter
End If
'Setting RngResult to cover the imported list (headers included).
Set RngResult = RngResult.Offset(-1, 0)
Set RngResult = WksDashboard.Range(RngResult, RngResult.End(xlDown).End(xlToRight))
'Creating WksPivotTable.
Set WksPivotTable = Sheets.Add
'Creating PvtPivotTable01.
Set PvtPivotTable01 = ActiveWorkbook.PivotCaches.Create(SourceType:=xlDatabase, _
SourceData:=RngResult, _
Version:=7 _
).CreatePivotTable(TableDestination:=WksPivotTable.Cells(1, 1), _
TableName:="Temporary Pivot Table", _
DefaultVersion:=7 _
)
'Setting PvtPivotTable01.
With PvtPivotTable01.PivotFields(StrInvestmentNameHeader)
.Orientation = xlRowField
.Position = 1
End With
With PvtPivotTable01
.AddDataField .PivotFields(StrQuantityHeader), "Sum of " & StrQuantityHeader, xlSum
.AddDataField .PivotFields(StrAfterChargeHeader), "Sum of " & StrAfterChargeHeader, xlSum
.AddDataField .PivotFields(StrCurrentPLHeader), "Sum of " & StrCurrentPLHeader, xlSum
.ColumnGrand = False
End With
'Clearing the data from RngResult.
RngResult.Offset(1, 0).Resize(RngResult.Rows.Count - 1).ClearContents
'Copying the PvtPivotTable01 content to RngResult.
PvtPivotTable01.DataBodyRange.Offset(0, -1).Resize(, PvtPivotTable01.DataFields.Count + 1).Copy RngResult.Cells(2, 1)
'Deleting WksPivotTable.
Application.DisplayAlerts = False
WksPivotTable.Delete
Application.DisplayAlerts = True
'Restoring screen updating.
Application.ScreenUpdating = False
End Sub
I've intentionally made it longer than the necessary, especially by creating many variables to avoid hard coded data. This method might be useful in more complex and/or longer codes.

copy, paste, transpose rows with pictures

I have a macro that copies and pastes rows from input sheet to output sheet. I find PRODUCT NAME and END DATE, then copy the whole row and transpose when pasting it. I am using transpose because I want to have vertical table.
I have a problem with images because I don't know how to copy them to proper cell so they match with Name and Date. I've managed to write a script that is copying and pasting images but it puts all of them in cell A1. When I want to add range to target_sheet.Paste I am getting vba method intersect of object _application failed error.
Below you can see how input and output sheets look.
Input sheet:
Expected output sheet (with only 3 columns) :
It is very important to know that 'input' sheet contains many products with names, prices and images and there is always a blank row between them. The number of images in each row can be different (from 1 to 25).
Sub copy_paste()
Dim Cell As Range
Dim src_rng As String
Dim LR As Long
Dim source_sheet As Worksheet
Dim target_sheet As Worksheet
Dim pic As Shape
'worksheet with source data
Set source_sheet = ThisWorkbook.Sheets("input")
'worksheet with newly created template
Set target_sheet = ThisWorkbook.Sheets("output")
'range of cells I want to check
src_rng = "A14:A26"
Application.ScreenUpdating = False
target_sheet.Cells.Delete
'copy paste, transpose product line rows
For Each Cell In source_sheet.Range(src_rng)
LR = target_sheet.Range("A10000").End(xlUp).Row + 1
If Cell.Value = "Name" Then
Cell.EntireRow.Copy
target_sheet.Range("A" & LR).PasteSpecial Paste:=xlPasteValues, Transpose:=True
End If
Next
'copy paste, transpose end line rows
For Each Cell In source_sheet.Range(src_rng)
LR = target_sheet.Range("B10000").End(xlUp).Row + 1
If Cell.Value = "Date" Then
Cell.EntireRow.Copy
target_sheet.Range("B" & LR).PasteSpecial Paste:=xlPasteValues, Transpose:=True
End If
Next
'copy paste image
For Each Cell In source_sheet.Range(src_rng)
LR = target_sheet.Range("C10000").End(xlUp).Row + 1
If Cell.Value = "Image" Then
For Each pic In source_sheet.Shapes
If Not Application.Intersect(pic.TopLeftCell, Range(src_rng)) Is Nothing Then
pic.CopyPicture
target_sheet.Paste
End If
Next pic
End If
Next
Application.ScreenUpdating = True
End Sub
Please, try the next code. It follows the logic deduced from your last question edit, respectively: the former "Name" becomes "Product Name", "Date" becomes "End Date" and the row keeping the pictures is the one below "Product Name" row. It is able to process two or three product names/pictures per group:
Sub copy_paste()
Dim Cell As Range, src_rng As String, LR As Long
Dim source_sheet As Worksheet, target_sheet As Worksheet
Dim pic As Shape, arrPAddr, rngTr As Range, k As Long
Dim cellRHeight As Range, nrShapesPerRange As Long 'to be 2 or 3
nrShapesPerRange = 2 'Choose here initial number of shapes per row (2 or 3)
'worksheet with source data
Set source_sheet = ThisWorkbook.Sheets("input")
'worksheet with newly created template
Set target_sheet = ThisWorkbook.Sheets("output")
'range of cells I want to check
src_rng = "A14:A26"
Application.ScreenUpdating = False
ReDim arrPAddr(1 To 2, 1 To source_sheet.Shapes.count): k = 1
target_sheet.cells.Delete: For Each pic In target_sheet.Shapes: pic.Delete: Next
'copy paste, transpose product line rows
For Each Cell In source_sheet.Range(src_rng)
LR = target_sheet.Range("A" & rows.count).End(xlUp).row + 1
If Cell.value = "Product Name" Then
source_sheet.Range(Cell.Offset(, 1), Cell.Offset(, 3)).Copy
Set rngTr = target_sheet.Range("A" & LR)
rngTr.PasteSpecial Paste:=xlAll, Transpose:=True
arrPAddr(1, k) = Cell.Offset(1, 1).Address
arrPAddr(2, k) = rngTr.Offset(, 2).Address: k = k + 1
arrPAddr(1, k) = Cell.Offset(1, 2).Address
arrPAddr(2, k) = rngTr.Offset(1, 2).Address: k = k + 1
If nrShapesPerRange = 3 Then
arrPAddr(1, k) = Cell.Offset(1, 3).Address
arrPAddr(2, k) = rngTr.Offset(2, 2).Address: k = k + 1
End If
If cellRHeight Is Nothing Then Set cellRHeight = Cell.Offset(1)
End If
LR = target_sheet.Range("B" & rows.count).End(xlUp).row + 1
If Cell.value = "End Date" Then
source_sheet.Range(Cell.Offset(, 1), Cell.Offset(, 3)).Copy
Set rngTr = target_sheet.Range("B" & LR)
rngTr.PasteSpecial Paste:=xlAll, Transpose:=True
End If
Next
ReDim Preserve arrPAddr(1 To 2, 1 To k - 1)
'Making the row height in target_sheet equal to source_sheet column with:
target_sheet.Range("2:" & LR + 3).EntireRow.RowHeight = source_sheet.Range("A16").EntireRow.RowHeight
target_sheet.Range("A:C").EntireColumn.AutoFit
target_sheet.Range("C1").EntireColumn.ColumnWidth = cellRHeight.EntireColumn.ColumnWidth
'copy paste image:
Dim i As Long
For Each pic In source_sheet.Shapes
For i = 1 To UBound(arrPAddr, 2)
If pic.TopLeftCell.Address = arrPAddr(1, i) Then
pic.Copy: target_sheet.Paste
With target_sheet.Shapes(target_sheet.Shapes.count)
.top = target_sheet.Range(arrPAddr(2, i)).top + (target_sheet.Range(arrPAddr(2, i)).RowHeight - pic.height) / 2
.left = target_sheet.Range(arrPAddr(2, i)).left
End With
Exit For
End If
Next i
Next
Application.ScreenUpdating = True
target_sheet.Activate
MsgBox "Ready..."
End Sub
Plese, test the code and send some feedback

performance issue - Rearranging columns based on column header

I have an Excel Workbook with hundreds of columns to be rearranged. Having tried different approaches to rearrange those columns I have developed my own solution, because it's faster than what I have found here and elsewhere:
How to rearrange the excel columns by the columns header name
https://code.adonline.id.au/rearrange-columns-excel-vba/
My code:
What I basically do is searching the header row for a certain string and copy that column to a temp/helper sheet, when done I search for the next term and so on until all categories are searched. Afterwards I copy the chunk back to the main sheet in the correct order.
edit: it is of vital importance to keep the formatting of each column, so putting everything in an array does not work, because the formatting information will be gone.
Sub cutColumnsToTempAndMoveBackSorted()
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
Call declareVariables
iCountCompanies = lngLastCol - iColStart + 1
' Timer
Dim StartTime As Double
Dim SecondsElapsed As Double
' Remember time when macro starts
StartTime = Timer
iStartColTemp = 0
wsTempCompanies.UsedRange.Delete
' First copy all columns with "ABC"
For i = iColStart To lngLastCol
If ws.Cells(iRowCategory, i) = "ABC" Then
iStartColTemp = iStartColTemp + 1
ws.Columns(i).Copy
wsTempCompanies.Columns(iStartColTemp).Insert
End If
Next i
' Then copy all columns with "DDD"
For i = iColStart To lngLastCol
If ws.Cells(iRowCategory, i) = "DDD" Then
iStartColTemp = iStartColTemp + 1
ws.Columns(i).Copy
wsTempCompanies.Columns(iStartColTemp).Insert
End If
Next i
' Then copy all columns with "CCC"
For i = iColStart To lngLastCol
If ws.Cells(iRowCategory, i) = "CCC" Or ws.Cells(iRowCategory, i) = "" Then
iStartColTemp = iStartColTemp + 1
ws.Columns(i).Copy
wsTempCompanies.Columns(iStartColTemp).Insert
End If
Next i
' Then copy all columns with "EEE"
For i = iColStart To lngLastCol
If ws.Cells(iRowCategory, i) = "EEE" Then
iStartColTemp = iStartColTemp + 1
ws.Columns(i).Copy
wsTempCompanies.Columns(iStartColTemp).Insert
End If
Next i
Dim iLastColTemp As Integer: iLastColTemp = iStartColTemp
iStartColTemp = 1
ws.Range(Col_Letter(iColStart) & ":" & Col_Letter(lngLastCol)).Delete 'Col_Letter function gives back the column ist characters instead of column ID
' Move back to Main Sheet
wsTempCompanies.Range(Col_Letter(iStartColTemp) & ":" & Col_Letter(iLastColTemp)).Copy
ws.Range(Col_Letter(iColStart + 1) & ":" & Col_Letter(lngLastCol + 1)).Insert
ws.Columns(iColStart).Delete
'Determine how many seconds code took to run
SecondsElapsed = Round(Timer - StartTime, 2)
'Notify user in seconds
Debug.Print "Time: " & SecondsElapsed & " Sekunden."
ende:
Application.ScreenUpdating = True
Call activateApplication ' All kinds of screenupdates, such as enableevents, calculations, ...
End Sub
I am still not happy with my solution as it takes just too much time when there are more than 50 columns. Sometimes I have over 300.
Any suggestion to boost the performance?
The below might be of some help, if it is not too much effort.
Sample Dataset in one sheet (let's call this the Main sheet) with,
(Row 2) Sample Header row (includes the lookup keywords - ABC, DDD, CCC, EEE)
(Row 1) A Temp Row (formulated to show Header Order numbers)
References sheet which lists the lookup keywords in required left-to-right sort order
Back in the Main sheet, we'd like to generate the sequence numbers in Row 1.
As highlighted in the 1st image, it can be done with the below MATCH formula in the cell A1,
=MATCH(TRUE,ISNUMBER(SEARCH(References!$A$2:$A$5,A2)),0)
This is required as an array formula and hence should be executed by hitting Ctrl+Shift+Enter
Now copy the cell A1 across columns (in Row 1) through the last column
Row 1 will now contain sequence numbers 1..n, where n is the numbers of rows found in the References sheet. It may also contain #N/A error value returned by the MATCH formula if no match is found from the 'References' sheet
Now, apply sort (Sort Option: Left to Right) and Sort By Row 1.
The columns should now be sorted as per requirement and with formatting intact.
Result (Sorted)
Please note that a column header not matching any keywords has been moved to the end.
Once you find everything in place, now you can go ahead and delete the (Row 1) temp row in the Main sheet
P.S: While I haven't computed the performance of this approach on a large dataset, I'm sure it will be fairly quick.
Please test the next code, please. Most of the credit must go to #Karthick Ganesan for his idea. The code only puts his idea in VBA:
Sub reorderColumnsByRanking()
Dim sh As Worksheet, arrOrd As Variant, lastCol As Long, i As Long
Dim El As Variant, boolFound As Boolean, isF As Long
Set sh = ActiveSheet 'use here your necessary sheet
lastCol = sh.Cells(1, Columns.Count).End(xlToLeft).Column
arrOrd = Split("ABC|1,DDD|2,CCC|3,EEE|4", ",") 'load criteria and their rank
'insert a helping row____________________
sh.Range("A1").EntireRow.Insert xlAbove
'________________________________________
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
'Rank the columns_______________________________________________________________
For i = 1 To lastCol
For Each El In arrOrd
If IsFound(sh.Cells(2, i), CStr(Split(El, "|")(0))) Then
sh.Cells(1, i).Value = Split(El, "|")(1): boolFound = True: Exit For
End If
Next
If Not boolFound Then sh.Cells(1, i).Value = 16000
boolFound = False
Next i
'_______________________________________________________________________________
'Sort LeftToRight_____________________________________________________________
sh.Sort.SortFields.Add2 key:=sh.Range(sh.Cells(1, 1), sh.Cells(1, lastCol)) _
, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With sh.Sort
.SetRange sh.Range(sh.Cells(1, 1), sh.Cells(1, lastCol)).EntireColumn
.Header = xlYes
.Orientation = xlLeftToRight
.SortMethod = xlPinYin
.Apply
End With
'____________________________________________________________________________
'Delete helping first row____
sh.Rows(1).Delete xlDown
'____________________________
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.Calculation = xlCalculationManual
End Sub
Private Function IsFound(rng As Range, strS As String) As Boolean
Dim fC As Range
Set fC = rng.Find(strS)
If Not fC Is Nothing Then
IsFound = True
Else
IsFound = False
End If
End Function
Here's my take on the solution. It's pretty similar to the one in your first link by #BruceWayne except this will go straight to the correct column rather than checking each one.
At the moment the code looks for partial matches - so "ABCDEF" would be found for both "ABC" and "DEF". Change xlPart to xlWhole in the FIND command to have it match against exact headings.
Sub Test()
Dim CorrectOrder() As Variant
Dim OrderItem As Variant
Dim FoundItem As Range
Dim FirstAddress As String
Dim NewOrder As Collection
Dim LastColumn As Range
Dim NewPosition As Long
Dim tmpsht As Worksheet
CorrectOrder = Array("ABC", "DEF", "GHI", "JKL")
With ThisWorkbook.Worksheets("Sheet1")
Set LastColumn = .Cells(2, .Columns.Count).End(xlToLeft) 'Return a reference to last column on row 2.
Set NewOrder = New Collection
With .Range(.Cells(2, 1), LastColumn) 'Refer to the range A2:LastColumn.
'Search for each occurrence of each value and add the column number to a collection in the order found.
For Each OrderItem In CorrectOrder
Set FoundItem = .Find(What:=OrderItem, After:=.Cells(1, 1), LookIn:=xlValues, LookAt:=xlPart)
If Not FoundItem Is Nothing Then
FirstAddress = FoundItem.Address
Do
NewOrder.Add FoundItem.Column
Set FoundItem = .FindNext(FoundItem)
Loop While FoundItem.Address <> FirstAddress
End If
Next OrderItem
End With
End With
'Providing some columns have been found then move them in order to a temporary sheet.
If NewOrder.Count > 1 Then
NewPosition = 2
Set tmpsht = ThisWorkbook.Worksheets.Add
For Each OrderItem In NewOrder
ThisWorkbook.Worksheets("Sheet1").Columns(OrderItem).Cut _
tmpsht.Columns(NewPosition)
NewPosition = NewPosition + 1
Next OrderItem
'Copy the reordered columns back to the original sheet.
tmpsht.Columns(2).Resize(, NewOrder.Count).Cut _
ThisWorkbook.Worksheets("Sheet1").Columns(2)
'Delete the temp sheet.
Application.DisplayAlerts = False
tmpsht.Delete
Application.DisplayAlerts = True
End If
End Sub
You can use Cut which is significantly faster (on PC it is around 20-30 times faster than Copy/Insert approach. Cut also preserves formatting.
Here, is an example how it can be implemented into your code:
For i = iColStart To lngLastCol
If ws.Cells(iRowCategory, i) = "EEE" Then
iStartColTemp = iStartColTemp + 1
ws.Columns(i).Cut wsTempCompanies.Columns(iStartColTemp)
End If
Next i
If for some reason, you are not allowed to cut elements from ws, then it is probably good idea to create temporary copy of that working to work on.

Copying values from one sheet based on condition to another workbook

I've written some code that assigns each item in a list a code based on row #. What I want to do from there is choose a copy all information from each row that corresponds with a chosen code, then paste it to another workbook. I've been having some trouble. Here's the code:
Sub LSHP_Distribute()
Dim wbLSHP As Workbook
Dim wsLSHP As Worksheet
Dim CodeRange As Range
Dim FirstRow As Long
Dim LastRow As Long
Dim wbTEST As Workbook
Set wbLSHP = ActiveWorkbook
Set wsLSHP = wbLSHP.Sheets("Sheet1")
'Generate codes for newly added items
Application.ScreenUpdating = False
'Turn off screen updating
With wsLSHP
FirstRow = .Range("F3").End(xlDown).Row + 1
LastRow = .Range("B6", .Range("B6").End(xlDown)).Rows.Count + 5
Set CodeRange = .Range("$F$" & FirstRow, "$F$" & LastRow)
End With
For Each cell In CodeRange
If cell = "" Then
If cell.Row Mod 3 = 0 Then
cell.Value = "1"
ElseIf cell.Row Mod 3 = 1 Then
cell.Value = "2"
ElseIf cell.Row Mod 3 = 2 Then
cell.Value = "3"
Else
End If
End If
Next cell
'Open Spreadsheets to Distribute Items
Dim PasteRow As Long
Dim i As Integer
Set wbTEST = Workbooks.Open(Filename:="V:\Test.xlsx")
PasteRow = wbTEST.Sheets("Sheet1").Range("B6").End(xlDown).Row + 1
Below is where I'm having the problem
wbLSHP.Activate
For Each cell In CodeRange
If cell = "1" Then
Range(ActiveCell.Offset(0, -5), ActiveCell.Offset(0, 20)).Select
Selection.Copy
wbTEST.Sheets("Sheet1").Cells(PasteRow, 1).PasteSpecial xlPasteValues
PasteRow = PasteRow + 1
Else
End If
Next cell
End Sub
First problem is the For loop isn't copying the correct range in "CodeRange", the second problem is it only copies once before I get an Automation Error. Let me know if you have any questions, or know of a more efficient way to write this code.
Thanks so much for your time!
Your range is defined to Start in F3 and end in BSomething, but you store to CodeRange only the F column.
Set CodeRange = .Range("$F$" & FirstRow, "$F$" & LastRow)
Try using:
Set CodeRange = .Range("$B$" & FirstRow, "$F$" & LastRow)
I suggest instead of Copy and Paste, assign the value to a variable and put the value of the variable on wbTEST.

VBA Check duplicates (column) and copy cells from one row to another that is duplicate

Excel 2007 [VB]
In my macro I filter by color to find duplicated values (on column "J" I have Highlight Cells Rules - Duplicates). Duplicated records in column "J" are named in column "K" as "Copy" or "Original".I would like to find "Copy" for each "Original" record which is always under (but not 1 but more rows) and copy cells value from column N:R of "Copy" row to row with "Original".
I hope I wrote it clearly but if not screenshot under.
Table
Begining of my macro:
Sub copy_original()
Dim lastRow As Long
Dim wb2 As Excel.Workbook
Application.DisplayAlerts = False
Application.AlertBeforeOverwriting = False
Application.ScreenUpdating = True
Set wb2 = ThisWorkbook
wb2.Sheets("Sheet1").AutoFilterMode = False
wb2.Sheets("Sheet1").Range("A4:U4").AutoFilter Field:=10, Criteria1:=RGB(255, 204, 0), Operator:=xlFilterCellColor
lastRow = wb2.Sheets("Sheet1").Cells(Rows.Count, "C").End(xlUp).Row
For x = lastRow To 5 Step -1
If...
...
wb2.Sheets("Sheet1").AutoFilterMode = False
End Sub
I looked for something similiar that can help and I found such a scripts:
Check if one cell contains the EXACT same data as another cell VBA
Find cells with same value within one column and return values from separate column of same row
Excel: Check if Cell value exists in Column, and return a value in the same row but different column
But to be honest I can't figure it out how to connect it into one working macro.
I would be gratefull for help.
Try this:
Sub copy_original()
Dim filteredRng As Range, cl As Range, rw As Integer
Application.DisplayAlerts = False
Application.AlertBeforeOverwriting = False
Application.ScreenUpdating = True
With ThisWorkbook.Worksheets("Sheet1")
.AutoFilterMode = False
.Range("A4:U4").AutoFilter Field:=10, Criteria1:=vbRed, Operator:=xlFilterCellColor
Set filteredRng = .Range("J5:J" & .Cells(Rows.Count, "J").End(xlUp).Row)
For Each cl In filteredRng.SpecialCells(xlCellTypeVisible)
If cl.Offset(0, 1) = "Original" Then
Range("L" & rw & ":R" & rw).Copy Destination:=cl.Offset(0, 2)
End If
rw = cl.Row
Next cl
.AutoFilterMode = False
End With
End Sub
You can try that;
For x = 5 to lastRow
If Cells(x,11) = "Copy" Then
For y = x+1 to LastRow
If Cells(y,10).Value = Cells(x,10) then
Cells(y,14) = Cells(x,14)
Cells(y,15) = Cells(x,15)
Cells(y,16) = Cells(x,16)
Cells(y,17) = Cells(x,17)
Cells(y,18) = Cells(x,18)
End If
Next y
End If
Next x

Resources