Posts by 7absinth

Wow. Actually this works well. Very big thank you for your help delving this problem.

Nice try pike . But this is similar that I have made before without rules. But now there is the rules you didn't noticed.

The first rule as you see is :

1) 'Check if certain selected cell through loop in column B:B starts with "33". If yes (>0) then copy this cell to ws2 in k row

And the second one is (if the first rule is triggered)

2) 'Check if certain selected cell through loop in column A:A starts with "UK". If yes (>0) then copy entire to ws2 in k row

Both are commented in the code. You can check the format (M1:N9) that are marked in yellow to see the format how it should to look.

Hello everybody.

I am struggling with the solution to copy out specific cells sequentially through the cells from 2 columns, but still no luck to complete it. Currently it do nothing.

The format that I want:

Sub test()

Dim ws, ws2 As Worksheet, v As Variant, k As Long, i

Application.DisplayAlerts = False
Application.ScreenUpdating = False

On Error Resume Next

Sheets("NewSheet").Delete

k = 1
Sheets.Add.Name = "NewSheet"

Set ws = Worksheets("Details for we 200522")
Set ws2 = Worksheets("NewSheet")


ws.Activate
    For Each xcell In Intersect(Range("B:B"), ws.UsedRange)
         'Check if certain selected cell through loop starts with "33". If yes (>0) then copy this cell to ws2 in k row
         i = xcell.Value
         If InStr(i, Left(i, 2)) > 0 Then
            i.Copy ws2.Cells(k, 1)
            k = k + 1
            'to keep the format continue to check A:A column to proceed information copying
            For Each ycell In Intersect(Range("A:A"), ws.UsedRange)
                'Check if certain selected cell through loop starts with "UK". If yes (>0) then copy entire row to ws2 in k row
                j = ycell.Value
                    If InStr(j, Left(j, 2)) > 0 Then
                        i.Copy.EntireRow ws2.Cells(k, 1)
                        k = k + 1
                    End If
            Next ycell
          End If
    Next xcell
    
'Delete unnecessary columns to make the needed format
ws2.Range(Cells(1, 2), Cells(1, 7)).EntireColumn.Delete

Application.ScreenUpdating = True
Application.DisplayAlerts = True

End Sub

Where is the problem?

See below the file what I want to get.

Wow. I didn't expect it will be so complicated script. However I found an error in extraction sheet, where B values with 0 in the front are disappeared:

I formatted entire sheet as text and after that B column values were shown correctly.

Thanks a lot!

This is very simple, but I am still struggling how to write the script correctly. So I have a table that have information in multiple columns in following layout

The goal is find the correct VBA routine to cut/extract data from columns to rows in following layout, keeping only table title in another sheet:

Maybe there are the solution?

Very appreciate any help.

Thanks

Thanks a lot, Barry. I tested it and just noticed small errors under:

If x = 21 Then
                x = [B][COLOR=#FF8C00]2[/COLOR][/B]
                c = c + 1
            End If

But overall works well. Also needed to change this part too:

With Me        
[B][COLOR=#FF0000].Columns.Delete[/COLOR][/B]

because it doesnt delete colors when sheet list is reduced. Again thanks so much for your time. I will subscribe to your profile and like your post.

God bless you.

Quote from iwrk4dedpr

you can attach a sample workbook. that has your current code. I see what you want now .... give me a sample workbook to work with will make assisting easier.

Sample added.

I have a following code that list and link all my worksheets in one long list. Now I come to the fact that this linked list is too long to me and I wonder if it's possible to split long linked lists into columns. I have seen separate codes that just copy out the values and split list into columns but in my case I want these cells linked too. So I am stuck and no idea how to implement code in this macro. Below is my macro.

Private Sub Worksheet_Activate()


Dim xSheet As Worksheet, x As Long, xName As Name


Application.ScreenUpdating = False


Me.Move Before:=Sheets(1)
x = 1


    With Me
        .Columns(1).ClearContents
        .Cells(1, 1) = "INDEX"
        .Cells(1, 1).Name = "INDEX"
        .Cells(1, 1).Font.Bold = 1
        .Cells(1, 1).Borders(xlEdgeBottom).LineStyle = xlDouble
    End With


    For Each xSheet In Worksheets
        If xSheet.Name <> Me.Name Then
            x = x + 1
            With xSheet
                ' Uncomment for the first use and launch. The comment again.
'                 .Rows("1:1").Insert Shift:=xlUp
'                 .Rows("1:1").Clear
                .Range("A1").Name = "_" & .Name
                .Hyperlinks.Add Anchor:=.Range("A1"), Address:="", SubAddress:="INDEX", TextToDisplay:="Back to Index"
                .Range("A1").Font.ColorIndex = xlAutomatic
                .Range("A1").Font.Bold = 1
                Me.Hyperlinks.Add Anchor:=Me.Cells(x, 1), Address:="", SubAddress:="_" & .Name, TextToDisplay:=.Name
                Me.Cells(x, 1).Font.Underline = xlUnderlineStyleNone
                Me.Cells(x, 1).Font.ColorIndex = xlAutomatic
                Me.Cells(x, 1).Font.Bold = 1
            End With
        End If
'       Me.Columns(1).AutoFit
    Next xSheet


Application.ScreenUpdating = True


End Sub

How to do that?

Its works!! Nice shot! Thanks a lot! I liked your post.

Quote from Mumps

Try:

Code

Sub AddListValuesInSheets()
Dim xRg As Range, sh As Worksheet
Set dbrange = Application.InputBox("Range: ", "Select Range", Application.Selection.Address, Type:=8)
Application.ScreenUpdating = False
For Each sh In ActiveWorkbook.Worksheets
For Each xRg In dbrange
sh.Range(xRg.Address) = xRg.Value
Next xRg
Next sh
Application.ScreenUpdating = True
End Sub

Display More

It is not what I am looking for and it doesnt work correctly.

Again - I have a vertical list with values ie A1, A2, A3. I want these values pasted/distributed in each sheet in cell D3 separately. This means to paste next value from the list in n-sheet cell D3- ie in Sheet2 in cell D3 will be value A1, in Sheet3 in cell D3 will be value A2 and in Sheet4 in cell D3 will be value A3 and so on.

I have a list with values and I want to copy and paste each value in each sheet in the same location. I tried to create code by myself and searched information but I am still stuck to figure out how to do this.

Below is code.

Sub AddListValuesInSheets()


Dim xRg As Range, sh As Worksheet


On Error GoTo Quit
Set dbrange = Application.InputBox("Range: ", "Select Range", _
Application.Selection.Address, Type:=8)
    
Application.ScreenUpdating = False


For Each xRg In dbrange
    For Each sh In ActiveWorkbook.Worksheets
        sh.Range("D3").Value = xRg.Value
    Next sh
Next xRg
    
Application.ScreenUpdating = True
Quit:


End Sub

Where is the problem? This code go through all sheets to paste the LAST cell from the list. And this is not that I want.

Quote from Luke M

Try it like this

This is amazing how few lines were needed. Works as charming. You are my wizard Luke. :cool: Thanks a lot.

I only deleted wSheet in your lines, because there are With wSheet operator already.

I could not to find the best thread for my issue anywhere.

I have a following code (see below) that Index sheets dynamically. Now is a problem to implement the code that color Index cells when I color that tab. For example when I color T1 tab in green it will color relevant cell in the INDEX tab. In this example it will be A2. When I color T3 tab code will color A3 cell in the INDEX tab and so on. See picture.

[VBA]Private Sub Worksheet_Activate()

Dim wSheet As Worksheet, l As Long

Application.ScreenUpdating = False

Me.Move Before:=Sheets(1)
l = 1

With Me
.Columns(1).ClearContents
.Cells(1, 1) = "INDEX"
.Cells(1, 1).Name = "Index"
.Cells(1, 1).Font.Bold = 1
End With

For Each wSheet In Worksheets
If wSheet.Name <> Me.Name Then
l = l + 1
With wSheet
' Uncomment for the first time then comment again
' .Rows("1:1").Insert Shift:=xlUp
' .Rows("1:1").Clear
.Range("A1").Name = "Start_" & .Index
.Hyperlinks.Add Anchor:=.Range("A1"), Address:="", _
SubAddress:="Index", TextToDisplay:="Back to Index"
.Range("A1").Font.ColorIndex = xlAutomatic
Me.Hyperlinks.Add Anchor:=Me.Cells(l, 1), Address:="", _
SubAddress:="Start_" & .Index, TextToDisplay:=wSheet.Name
End With
End If
Me.Columns(1).AutoFit
Next wSheet

Application.ScreenUpdating = True

End Sub[/VBA]

[ATTACH=JSON]{"alt":"Click image for larger version Name:\tSample.JPG Views:\t1 Size:\t24.1 KB ID:\t1193524","data-align":"none","data-attachmentid":"1193524","data-size":"full","title":"Sample.JPG"}[/ATTACH]

Re: Sum from two Tables based on From-To Date criteria

<p>
Work like a charm. God bless you.</p>

I have two spreadsheets that are in two tables. In each tab is same table format. And here is the problem. In each table has date and data column. And I just try to create a formula that sums values between two dates where the first date is the oldest date that I dont want to enter (so it must to be in formula) and date that I input manually. So only one criteria (TO date) need to enter, but I am confused how to calculate from two tables if sumif sumproduct and sum doesnt work as I expected. Is this possible in general to resolve? I have attached a sample.

Re: Insert No linked picture in the cell with formatting VBA

Seems I found the solution. Thank you for your help.:thumbcoo:

I wrote the following lines:

With pic
            .LockAspectRatio = msoFalse
            .Placement = xlMoveAndSize
        End With

AND gotcha.

Re: Insert No linked picture in the cell with formatting VBA

Nice idea to define as shape but I mean this picture in the cell. Macro works but it doesnt stretch with the cell (LockAspectRatio) as it's when pic variable define as picture. And here I am stuck.

I found the difficulties to find the right approach in Excel HOW I can to format inserted object (picture) with line borders and colors etc.

Option Explicit
Sub ImportPictureNoLinked()




Dim fd As Office.FileDialog, pic As Object




Set fd = Application.FileDialog(msoFileDialogFilePicker)




With fd
.AllowMultiSelect = False
.Title = "Please select the file"
.Filters.Add "Images", "*.gif; *.jpg; *.jpeg; *.bmp; *.tif; *.png"
.FilterIndex = 2




If .Show = -1 Then




Set pic = ActiveSheet.Shapes.AddPicture(Filename:=.SelectedItems(1), LinkToFile:=False, _
SaveWithDocument:=True, Left:=ActiveCell.Left, Top:=ActiveCell.Top, _
Width:=ActiveCell.Width, Height:=ActiveCell.Height)




'<HERE I WANT A CODE THAT MAKE INSERTED PICTURE BORDER LINE WITH COLOR AND DISABLE LOCK ASPECT RATIO>




Set pic = Nothing




End If
End With
End Sub

Re: Count Chars/Words from Comments and TextBox VBA

Quote from pike;771171

[/CODE]

WOW. Really WOW. I am impressed. You are like macro magician :wowee:. Now its works as my wall clock.:congrats:

Re: Count Chars/Words from Comments and TextBox VBA

Quote from pike;771152

and shortened [..]
End Sub[/CODE]

I didnt think of about type for this part. All looks cool till I encountered it doesnt count TxtBox Words correctly. Now its counts TxtBox as Object. I added 1 text box and it counts as 1 word. No matter how many words are written inside.