2

I have two workbooks: Source.xlsm, sheet= Orig and Destination.xlsm, sheet=New

I am trying to move data between these sheets in a specific way: Example of both sheets before running the macro (the column ordering is on purpose)

enter image description here enter image description here

In the Orig sheet, cell F1 is storing today's date in the following format: dd mmm yy

My objective is to take only the rows from Orig with today's date and place all of them in a specific ordering to the end of the New sheet. So that after running the macro, New looks like:

enter image description here

Any suggestions as to how to progress would be amazing

I have the following code snippets to start to form a solution, all saved in Source.xlsm. This correctly select the bottom two rows of Orig since they have todays date in column D

Sub SelectTodayRows() Dim tableR As Range, cell As Range, r As Range Dim s As String Set tableR = Range("D1:D100000") Set r = Range("F1") For Each cell In tableR If cell = r Then s = s & cell.Row & ":" & cell.Row & ", " End If Next cell s = Left(s, Len(s) - 2) Range(s).Select End Sub

The next step is appending these selected rows in the correct column ordering to New.

Improve this question
3
  • The idea is not that bad but unfortunately, the Range.Address property only recognizes up to 255 or so characters so you need to abandon this idea. Does any of these workbooks contain this code? Do you want to append the new data or delete the previous, and then write the new data? Where is your data located, e.g. A2:ZLastRow? Could you add a screenshot of your data (source worksheet)? Commented Nov 5, 2022 at 14:07
  • Sure, I'll create a simpler example and update the question with pictures Commented Nov 5, 2022 at 14:13
  • @VBasic2008 I've updated it, please let me know if this is doable and if any additional explanations would help Commented Nov 5, 2022 at 14:40

1 Answer 1

Reset to default
1

Copy Data to Different Columns

Sub TransferToday() Const CriteriaColumn As Variant = 4 ' The leading "0, "-s are used to be able to use sCols(c) ' instead of sCols(c - 1) in the For...Next loop. Dim sCols() As Variant: sCols = VBA.Array(0, 1, 2, 3, 4) Dim dCols() As Variant: dCols = VBA.Array(0, 2, 4, 3, 1) Dim cCount As Long: cCount = UBound(sCols) Dim Today As Date: Today = Date ' TODAY() in excel Dim dwb As Workbook: Set dwb = Workbooks("Destination.xlsm") Dim dws As Worksheet: Set dws = dwb.Worksheets("New") Dim drg As Range: Set drg = dws.Range("A1").CurrentRegion.Resize(, cCount) ' Prevent copying if an occurrence of today's date is found in destination. ' If not needed, out-comment or delete, it doesn't interfere with the rest. Dim dCol As Variant dCol = dCols(Application.Match(CriteriaColumn, sCols, 0) - 1) If IsNumeric(Application.Match(CLng(Today), drg.Columns(dCol), 0)) Then MsgBox "Today's data had already been transferred.", vbExclamation Exit Sub End If Dim swb As Workbook: Set swb = ThisWorkbook ' workbook containing this code Dim sws As Worksheet: Set sws = swb.Worksheets("Orig") Dim srg As Range: Set srg = sws.Range("A1").CurrentRegion.Resize(, cCount) Dim srCount As Long: srCount = srg.Rows.Count Dim sData() As Variant: sData = srg.Value Dim dData() As Variant: ReDim dData(1 To srCount, 1 To cCount) Dim sr As Long Dim dr As Long Dim c As Long For sr = 1 To srCount If IsDate(sData(sr, CriteriaColumn)) Then ' is a date If sData(sr, CriteriaColumn) = Today Then ' is today's date dr = dr + 1 For c = 1 To cCount dData(dr, dCols(c)) = sData(sr, sCols(c)) Next c End If End If Next sr If dr = 0 Then MsgBox "No today's data found.", vbExclamation Exit Sub End If ' First Destination Row. Dim dfrrg As Range: Set dfrrg = drg.Resize(1).Offset(drg.Rows.Count) dfrrg.Resize(dr).Value = dData MsgBox "Today's data transferred.", vbInformation End Sub

The following might be useful if the dates are strings.

Const DateFormat As String = "dd mmm yy" Dim TodayString As String ' Either... TodayString = Format(Date, DateFormat) ' ... or... TodayString = Application.Text(Date, DateFormat) ' not English locale ' ... and there is only one If statement: If CStr(sData(sr, CriteriaColumn)) = TodayString Then

The prevent copying... block might also need modifying.

Improve this answer
Sign up to request clarification or add additional context in comments.

7 Comments

I understand sCols, meaning Name=1, product=2, quantity=3 and date=4. So dicols should be 0,4,1,3,2. Your version of dcols works but unsure as to why.
Also, is there a way to have a column space between the copied data ie the data would be copied in to New with the following columns: Date | Name | Quantity | Age| Product. So all columns apart from Age would be filled in as seen already? Thanks again
Its still not obvious to me why 1234, becomes 2431, since there is no logic for these changes in numbers given the changes in column orderings. Apologies if I'm missing something but 1234 becoming 2431 makes no sense to me
A quick fix would be to modify the following: dCols = VBA.Array(0, 2, 5, 3, 1), Set drg = dws.Range("A1").CurrentRegion, ReDim dData(1 To srCount, 1 To drg.Columns.Count). But this is messing up things. You should have mentioned that initially.
I apologise, I forgot to mention this aspect of the task. I'll ask it as another questions and thanks for your help
|

Start asking to get answers

Find the answer to your question by asking.

Ask question

Explore related questions

See similar questions with these tags.