Selected Answer
Your question lacks a work flow. Therefore I have created one for you. It may not be what you want, or even what you can use, but if we don't have anything to discuss we have no way to improve. This is the flow I have imagined:-
- You have a workbook that contains your database. That is a tab where you add entries every day. In the attached workbook I called it "Database".
- The same workbook also contains the code. Therefore it's of xlsm format (unlike the workbook you posted).
- There is a sheet in this same workbook called "DataToTranspose". Every day you copy data from your email to this sheet.
- Then you run the code, which transfers the new data in transposed format to the "Database" sheet.
- The data on the "DataToTranspose" tab are then deleted in preparation for the next day's batch.
Here is the code that does the transferring. It's very fast because it doesn't waste time reading from the sheet or writing to it. It just reads once and writes only once, doing all the transforming work on copies.
Sub TransferData()
' 170
Dim Ws As Worksheet ' source data sheet
Dim Source As Variant ' data to transpose
Dim Output As Variant ' the transposed data
Dim Rs As Long ' loop counter: rows (Source)
Dim C As Long ' loop counter: columns (Source)
Dim Rout As Long ' rows (Output)
Dim Cout As Long ' columns (Output)
' read the data to transpose into memory
Set Ws = Worksheets("DataToTranspose")
With Ws
' from A1 to end of column + 2 rows (searching from last sheet row up)
Source = .Range(.Cells(1, 1), .Cells(.Rows.Count, 1).End(xlUp).Offset(2))
' this will be 2 2D array with many rows and 1 column
End With
' dimension the output array:-
' 5 columns wide x as many rows as in the source data
ReDim Output(1 To 5, 1 To UBound(Source))
For Rs = 1 To (UBound(Source)) Step 6
Rout = Rout + 1
Output(1, Rout) = Date ' add the current date to each row
Cout = 1
For C = 0 To 3 ' 4 loops
' omit the 3rd column
If C <> 2 Then
Cout = Cout + 1
Output(Cout, Rout) = Source(Rs + C, 1)
End If
Next C
Next Rs
' erase unused portion of Output array
ReDim Preserve Output(LBound(Output) To UBound(Output), 1 To Rout)
With Worksheets("Database")
.Cells(.Rows.Count, "A").End(xlUp).Offset(1) _
.Resize(UBound(Output, 2), UBound(Output)).Value = Application.Transpose(Output)
.Range(.Columns(1), .Columns(4)).AutoFit ' adjust column widths
End With
' If Err.Number = 0 Then Ws.ClearContents
End Sub
There are a few peculiarities that require your attention beyond the creation of the workbook itself, synching the tab names with the code and saving the whole thing correctly.
- The "Database" tab already exists. In the attached workbook it already has column captions. My code doesn't add captions like yours.
- My workbook has an extra column for the current date. This isn't to suggest that you need a date but to show you where in the code to add information to each row. It could be a serial number or anything else, and t doesn't need to be in the first column, either.
- Observe the column management in the loop. First the extra information (Date) is written to the appropriate column (1 = A). Then the inside loop For C = 0 To 3 takes over. That copies 4 rows from the source data but one of them is skipped. I don't know if this is really what you intend but I took the hint as cause to show you how it can be done. As a result C and Cout (the column counter for the Output array) aren't identical. Of course, Cout must match the columns on the Database sheet.
- .Range(.Columns(1), .Columns(4)).AutoFit adjusts the widths of the sheet columns on every run. If you don't like the effect, remove the line. It's very useful while testing.
- The last line in the code is If Err.Number = 0 Then Ws.ClearContents. I never used it because I wanted to preserve the data. You always have a backup in the email you received. Therefore data preservation is less critical. Please enable that line when you are ready.
Meanwhile, the attached workbook is fully functionable. You can run the code repeatedly. Each run will append the new data to the existing.
