Posts by ipmh97

ipmh97 · Sep 16th 2021

[xpost][/xpost]

Currently, my excel sheet is composed of data that are not in long format. [Blocked Image: https://i.stack.imgur.com/48pNi.png]

I want to cut the data to paste at the bottom of the first 2 columns to get something like this:

[Blocked Image: https://i.stack.imgur.com/6FerU.png]

I have written some vba code to allow me to do the cutting and pasting. However, the code doesn't seem to exit the Find Loop and continuously finds and cuts. I want to stop finding after all columns after the 1st 2 are cut and pasted to the bottom. What edits can I make to the code to allow the find to escape the loop? Thank you

Code

Sub FindTextInSheets()
    Dim FirstAddress As String
    Dim myColor As Variant
    Dim rng As Range
    Dim Corp As Range
    Dim rowscount As Variant
    Dim rowsno As Integer
                Set rng = ActiveSheet.Cells.Find(What:="Code", _
                                After:=Range("B1"), _
                                LookIn:=xlValues, _
                                LookAt:=xlWhole, _
                                SearchOrder:=xlByColumns, _
                                SearchDirection:=xlNext, _
                                MatchCase:=False)
                If Not rng Is Nothing Then
                    FirstAddress = rng.Address
                    Do
                        rng.Select
                        Range(Selection, Selection.Offset(0, 1)).Select
                        Range(Selection, Selection.End(xlDown)).Select
                        Selection.Cut
                        Range("A1").Select
                        Selection.End(xlDown).Select
                        Selection.Offset(1, 0).Select
                        ActiveSheet.Paste
                        Set rng = ActiveSheet.Cells.FindNext(rng)
                    Loop While Not rng Is Nothing And rng.Address <> FirstAddress
                End If
        
        End Sub




[attach=1232546][/attach]

Display More

ipmh97 · Aug 20th 2021

Hi, I have to clean different excel sheets with separate tables within each sheet. I have written a vba code to extract rows between two values and paste them onto a new sheet. The issue I have now is that I want to consolidate the rows in the new sheet into a total instead of individual rows.

From the above pic, I want the total quantity (which is 9) for the top table to replace the "1" in the first row. Thereafter, I want to delete all rows below the first row of the table till the start of the next company. After that, I want to repeat the process for Company B's table. How do I write the vba code for this? I was thinking of using find to search for "Total" and use offset after that but I'm not sure if that's possible. I have uploaded the excel workbook. You need to run the Selectbetween macro first before reaching the above step. Thank you

ipmh97 · Jul 31st 2021

I can’t really post the workbooks due to sensitive information on them. Basically what I have is a directory with many different workbooks.

1) I need to extract information on from workbooks with the word “Report” in them

2) Of these “Report” workbooks, I only need information from certain sheets with titles from an array of names ( ie sheet names with “‘New”, “Continue” etc in them)

3) I need to check the columns of these sheets and add in any missing columns

4) What I’m doing currently is to copy these sheets onto the back of my compilation workbook

5) Lastly, I need to toggle through each sheet and copy the data there and paste them onto the last used row of the first sheet of the compilation workbook

ipmh97 · Jul 31st 2021

I am trying to collate specific sheets with "Report" in their names across different excel files and paste them into a new excel document, with each new sheet's data pasted below the last used row of the collated sheet. I also need to check for any missing headers in the different excel files and add a header at the appropriate location if its missing. I have combined vba codes I have found online to first copy all the "Report" sheets of files in the directory to the consolidated excel file and then search for missing headers before copying the data to paste in Sheet1. However, I have some issues Firstly the missing columns are not added when I run the code. Next, I'm not too sure on how to write the via to do the copying and pasting in the first sheet's last used row as it is not working.

Code

Sub AddMissingHeader()    
Dim headers() As Variant    
headers = Array("Report_Date", "Company", "Customer_Id", "Product_Id", "Company_Name")    
Dim i As Long    
For i = LBound(headers) To UBound(headers)        
If Cells(5, i + 1).Value <> headers(i) Then            
    Columns(i + 1).EntireColumn.Insert            
    Cells(5, i + 1).Value = headers(i)        
End If    
Next i    
End Sub




Sub SelectAndCopy()

Dim i As Integer
WS_Count = ActiveWorkbook.Worksheets.Count
For i = 2 To WS_Count    
    Worksheets(i).Select    
    Range("A3:M3").Select    
    Range(Selection, Selection.End(xlDown)).Select    
    Selection.Copy    
    Sheets("Sheet1").Select    
    Dim lstrow As Integer    'finds the last row    
    lstrow = ActiveSheet.UsedRange.Rows.Count    
    ActiveSheet.Range("A" & lstrow).Offset(1).Select    
    ActiveSheet.Paste
Next i

End Sub


Sub Collate()
Dim wbDst As Workbook
Dim wbSrc As Workbook
Dim wsSrc As Worksheet
Dim MyPath As String
Dim strFilename As String
Application.DisplayAlerts = False
Application.AskToUpdateLinks = False
Application.EnableEvents = False
Application.ScreenUpdating = False
MyPath = InputBox("Please copy and paste the path to the folder containing the source documents")
Set wbDst = ActiveWorkbook
strFilename = Dir(MyPath & "\*Report*.xls", vbNormal)
If Len(strFilename) = 0 Then Exit Sub
Do Until strFilename = ""    
    Set wbSrc = Workbooks.Open(Filename:=MyPath & "\" & strFilename)    
    For Each ws In wbSrc.Worksheets        
        If InStr(1, ws.Name, "New & Continuing", vbTextCompare) Then            
            Set wsSrc = ws            
            Call AddMissingHeader        
        End If    
    Next ws    
    wsSrc.Copy After:=wbDst.Worksheets(wbDst.Worksheets.Count)    
    wbSrc.Close False    
    strFilename = Dir()
Loop
Call SelectAndCopy

End Sub

Display More

Posts by ipmh97

Transpose data from wide format to long format excel

VBA Code to copy value in a cell and paste in at the first row of the Table and delete rows below after

Insert Missing Column in Worksheets and Paste Data onto new Excell

Insert Missing Column in Worksheets and Paste Data onto new Excell